CODEWITHSUNDEEP
excelvbacellworksheet
Daiichi_kun
Daiichi_kun

Reputation: 27

Copy Data with Matching Worksheet Name

I have a workbook containing worksheets "Summary" (where all data are consolidated, as shown), "8","9","10".
Fig.1

I want to copy the data from "Summary" with the condition that if cell in Column A contains the worksheet name (8, 9 or 10), that cell's row and Column C to E will pasted to the worksheet with matching name.
Fig.2

The pasted data will be offset to row 7, and each datum will be incremented with a space. For example, cells in Column A rows 2 to 6 in "Summary" contains "8", thus Columns C to E rows 2 to 6 will be copied and pasted to sheet "8".

Link to my macro file: https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

This code won't do the offset and increment:

Sub Copy_Data()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Double
Sheets("Summary").Activate
Dim lastrow As Long
lastrow = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As String

For i = 2 To lastrow
    ans = Cells(i, "A").Value
    Lastrowa = Sheets(ans).Cells(Rows.Count, "C").End(xlUp).Row
    Sheets("Summary").Rows(i).Columns("C:E").Copy
    Sheets(ans).Rows(Lastrowa + 1).Columns("C:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
Application.ScreenUpdating = True
End Sub

Upvotes: 0

Views: 861

Answers (2)

VBasic2008
VBasic2008

Reputation: 54807

From One to Several Worksheets

  • It is assumed that the Source Worksheet data is contiguous and starts in cell A1 (CurrentRegion).
  • Adjust the values in the constants section and the workbook.
Option Explicit

Sub CopyData()
    
    Const sName As String = "Summary" ' Source Worksheet Name
    Const sdCol As String = "A" ' Destination Worksheet Name Column
    Const sCols As String = "C:E" ' Source Copy Columns
    Const sFirst As Long = 2 ' Source First Row
    
    Const dCol As String = "C" ' Destination First (Paste) Column
    Const dFirst As Long = 7 ' Destination First Row
    Const drOffset As Long = 2 ' Destination Row Offset
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    Dim sLast As Long: sLast = srg.Rows.Count ' Source Last Row
    Dim cCount As Long: cCount = sws.Columns(sCols).Columns.Count
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range ' Source Row Range
    Dim r As Long ' Source Row Counter
    
    Dim dws As Worksheet ' Destination Worksheet
    Dim drrg As Range ' Destination Row Range
    Dim dCell As Range ' Destination Last Cell
    Dim dName As String ' Destination Worksheet Name
    
    For r = sFirst To sLast
        dName = CStr(srg.Columns(sdCol).Rows(r).Value)
        Set dws = Nothing
        On Error Resume Next
        Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If Not dws Is Nothing Then
            Set dCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp)
            If dCell.Row < dFirst Then
                Set drrg = dws.Cells(dFirst, dCol).Resize(, cCount)
            Else
                Set drrg = dCell.Offset(drOffset).Resize(, cCount)
            End If
            Set srrg = srg.Columns(sCols).Rows(r)
            drrg.Value = srrg.Value
        'Else
            ' Destination Worksheet doesn't exist.
        End If
    Next r
    
    Application.ScreenUpdating = True

End Sub

Upvotes: 1

marsidev
marsidev

Reputation: 61

Sub Copy_Data()
    Dim lastRow As Long, offsetRow As Long, i As Long, No As String, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
    Set summarySheet = Worksheets("Summary")
    lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    offsetRow = 7
    For i = 2 To lastRow
        No = Cells(i, "A")
        Set NOSheet = Worksheets(No)
        auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        If auxRow > 1 Then auxRow = auxRow + 2
        If auxRow = 1 Then auxRow = offsetRow
        NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
        NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
        NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
    Next i
End Sub

Upvotes: 1

Related Questions