VBA - copy and paste data to different tabs based on specific criteria

[SRokov]

I'm new to VBA so please be nice

I am trying to figure out how to write a macro that would copy and paste data based on a specific criteria to a specific workbook starting in a specific cell. For example, per below how would I write a code to copy Type A data to Sheet A starting at Cell A5 in Sheet A and also copy Type B data to Sheet B starting at Cell A5 in Sheet B? Can this be done using only one macro?

Using the recorder I am able to do each separate; however my actual data set requires upwards of 15 copy and pastes to different workbooks so running a separate macro for each is a little tedious.

Thanks!

 

[DacEasy]

Hi, I was able to create a macro based on your request. You have a section for you to add sheet name's and the keyword to search, just follow the pattern. It then calls a private macro that does the actually copying of data.

Option Explicit
    Dim lastRow As Long, nextRow As Long, i As Long, h As Long, wb As Workbook
    Dim main As Worksheet, sheetLetter As Worksheet, findWord As String, shName As String

Sub forSheets_To_Loop()
    
    shName = "Sheet A"
    findWord = "A"
    Call Copy_Data
    
    shName = "Sheet B"
    findWord = "B"
    Call Copy_Data
    
    shName = "Sheet C"
    findWord = "C"
    Call Copy_Data
    
End Sub

Private Sub Copy_Data()
    Set wb = ThisWorkbook
    Set main = wb.Sheets("Data")
    Set sheetLetter = wb.Sheets(shName)
        
    lastRow = main.Cells(Rows.Count, "A").End(xlUp).Row         'Find the lastRow
    nextRow = sheetLetter.Cells(Rows.Count, "A").End(xlUp).Row  'Find the lastRow if Headers are
                                                                'on Row 4, it will start placing
                                                                'data on Row 5
        
    h = 1                                                       'If there are no Headers,
                                                                'change h = 1 to h = 4
    For i = 2 To lastRow
        If main.Range("A" & i).Value = findWord Then            'Finds the data and puts on next row
            sheetLetter.Range("A" & nextRow + h) = main.Range("A" & i).Value
            sheetLetter.Range("B" & nextRow + h) = main.Range("B" & i).Value
            h = h + 1
        End If
    Next i
End Sub

 

[SRokov]

Hi, I was able to create a macro based on your request. You have a section for you to add sheet name's and the keyword to search, just follow the pattern. It then calls a private macro that does the actually copying of data.

Option Explicit
    Dim lastRow As Long, nextRow As Long, i As Long, h As Long, wb As Workbook
    Dim main As Worksheet, sheetLetter As Worksheet, findWord As String, shName As String

Sub forSheets_To_Loop()
  
    shName = "Sheet A"
    findWord = "A"
    Call Copy_Data
  
    shName = "Sheet B"
    findWord = "B"
    Call Copy_Data
  
    shName = "Sheet C"
    findWord = "C"
    Call Copy_Data
  
End Sub

Private Sub Copy_Data()
    Set wb = ThisWorkbook
    Set main = wb.Sheets("Data")
    Set sheetLetter = wb.Sheets(shName)
      
    lastRow = main.Cells(Rows.Count, "A").End(xlUp).Row         'Find the lastRow
    nextRow = sheetLetter.Cells(Rows.Count, "A").End(xlUp).Row  'Find the lastRow if Headers are
                                                                'on Row 4, it will start placing
                                                                'data on Row 5
      
    h = 1                                                       'If there are no Headers,
                                                                'change h = 1 to h = 4
    For i = 2 To lastRow
        If main.Range("A" & i).Value = findWord Then            'Finds the data and puts on next row
            sheetLetter.Range("A" & nextRow + h) = main.Range("A" & i).Value
            sheetLetter.Range("B" & nextRow + h) = main.Range("B" & i).Value
            h = h + 1
        End If
    Next i
End Sub

Thanks so much! I am getting a mismatch error on the line of code lastRow = main.Cells(Rows.Count, "A").End(xlUp).Row - any suggestions? I copied and pasted your code directly and updated as applicable for the actual sheet names and data source names. For some reason my 'end' is not showing up as blue like yours is?

 

[DacEasy]

The color blue only appears on this website. Option Explicit is at the top? It will help find variables not declared. Set main = wb.Sheets("Data"), you sure the right sheet name is in there and not Data? What is the first sheet called. Maybe send a screenshot of the sheet names in excel.