VBA to copy and paste based on multiple conditions

[Beginner001]

I have data that I want to paste on multiple sheets but some of the sheets does not contain all of the columns from the raw data.
Also, the sheets contains historical data so what I need is paste the new raw data to the next available row on the sheets.
I'm thinking of the following but i don't know if it can be done
1-Insert the required rows based on summary tab
2-isolate data for each sheet from "Raw data" tab using filter, then copy only columns that are present in the sheet using the first row as reference to the column name
3-delete entire row in the raw data tab once done with the copy
4-repeat the process once done with all the sheets

 

[OaklandJim]

I'll try to assist but I don't understand exactly what is needed. And, trying to write code would be challenging without something to work with. Fake data would have to be made up. Unlikely.

Might you post a link to a workbook with fake-but-realistic data? Put the file on Dropbox, 1 drive, etc. Post a link using the link icon above the message area.

If nothing else post data not pictures. Use Mr Excel's excellent addin called XL2BB which enables you to post portions of a worksheet. See HERE.

 

[kevin9999]

Try the following on a copy of your workbook. Assumes the sheet names & columns required are fixed.

Option Explicit
Sub Beginner001()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Raw Data")
    Dim ShtName As String, a, b, i As Long, j As Long, LRow As Long
    Dim RngSrc As Range, RngDest As Range
    a = Array("10008", "20006", "30004")
    
    For i = 0 To UBound(a)
        ShtName = a(i)
        Select Case ShtName
            Case "10008"
              b = Array(1, 2, 3, 4, 6, 7)
            Case "20006"
             b = Array(1, 2, 3, 5, 6, 9)
            Case "30004"
             b = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
        End Select
        
        LRow = Worksheets(ShtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A2", ws1.Cells(Rows.Count, "I").End(xlUp))
            .AutoFilter 3, ShtName
            Set RngSrc = .Offset(1)
            With RngSrc
                For j = LBound(b) To UBound(b)
                    If RngDest Is Nothing Then
                        Set RngDest = .Columns(b(j))
                    Else
                        Set RngDest = Union(RngDest, .Columns(b(j)))
                    End If
                Next j
                RngDest.Copy Worksheets(ShtName).Range("A" & LRow)
                Set RngDest = Nothing
            End With
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

Probably best to test in case you don't have new data for every sheet - every time you want to do an update.

Option Explicit
Sub Beginner001_V2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Raw Data")
    Dim ShtName As String, a, b, i As Long, j As Long, LRow As Long
    Dim RngSrc As Range, RngDest As Range
    a = Array("10008", "20006", "30004")
    
    For i = 0 To UBound(a)
        ShtName = a(i)
        Select Case ShtName
            Case "10008"
              b = Array(1, 2, 3, 4, 6, 7)
            Case "20006"
             b = Array(1, 2, 3, 5, 6, 9)
            Case "30004"
             b = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
        End Select
        
        LRow = Worksheets(ShtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A2", ws1.Cells(Rows.Count, "I").End(xlUp))
            .AutoFilter 3, ShtName
            If ws1.Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
                Set RngSrc = .Offset(1)
                With RngSrc
                    For j = LBound(b) To UBound(b)
                        If RngDest Is Nothing Then
                            Set RngDest = .Columns(b(j))
                        Else
                            Set RngDest = Union(RngDest, .Columns(b(j)))
                        End If
                    Next j
                    RngDest.Copy Worksheets(ShtName).Range("A" & LRow)
                    Set RngDest = Nothing
                End With
                .Offset(1).EntireRow.Delete
            End If
            .AutoFilter
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Beginner001]

Probably best to test in case you don't have new data for every sheet - every time you want to do an update.

Option Explicit
Sub Beginner001_V2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Raw Data")
    Dim ShtName As String, a, b, i As Long, j As Long, LRow As Long
    Dim RngSrc As Range, RngDest As Range
    a = Array("10008", "20006", "30004")
  
    For i = 0 To UBound(a)
        ShtName = a(i)
        Select Case ShtName
            Case "10008"
              b = Array(1, 2, 3, 4, 6, 7)
            Case "20006"
             b = Array(1, 2, 3, 5, 6, 9)
            Case "30004"
             b = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
        End Select
      
        LRow = Worksheets(ShtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A2", ws1.Cells(Rows.Count, "I").End(xlUp))
            .AutoFilter 3, ShtName
            If ws1.Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
                Set RngSrc = .Offset(1)
                With RngSrc
                    For j = LBound(b) To UBound(b)
                        If RngDest Is Nothing Then
                            Set RngDest = .Columns(b(j))
                        Else
                            Set RngDest = Union(RngDest, .Columns(b(j)))
                        End If
                    Next j
                    RngDest.Copy Worksheets(ShtName).Range("A" & LRow)
                    Set RngDest = Nothing
                End With
                .Offset(1).EntireRow.Delete
            End If
            .AutoFilter
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

Thank you for helping with this. I did a test run and it definitely worked.
However, is it possible to make it more dynamic? I noticed that I need to define the specific rows in the codes as well as the sheet names, my concern with this is that when a new sheet is added and or a new column is inserted to one of the sheets, I would need to look back into the codes and add them

 

[kevin9999]

Try the following on a copy of your workbook. It is now "dynamic", however, please note that it assumes that the columns required to be copied to each sheet (including any new sheets that may be added) will be listed in row 1 of each respective sheet.

Option Explicit
Sub Beginner001_V3()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Raw Data")
    Dim ShtName As String, a, b, i As Long, j As Long, LRow As Long, LCol As Long
    Dim RngSrc As Range, RngDest As Range
    
    'Get unique list of sheet names from the Raw Data sheet
    Dim d As Object, s As String, exists As Boolean, arr
    Set d = CreateObject("scripting.dictionary")
    arr = ws1.Range("C3", ws1.Cells(Rows.Count, "C").End(xlUp))
    For i = 1 To UBound(arr, 1)
        d(arr(i, 1)) = 1
    Next i
    a = d.keys
    
    'Check to make sure all those sheets actually exist
    For i = LBound(a) To UBound(a)
        s = a(i)
        For j = 1 To Worksheets.Count
            If Worksheets(j).Name = s Then
                exists = True
                Exit For
            End If
        Next j
        If Not exists Then
            MsgBox "The sheet " & s & " doesn't exist in this workbook"
            Exit Sub
        End If
        exists = False
    Next i
    
    'Get column array from each sheet
    For i = 0 To UBound(a)
        ShtName = a(i)
        LCol = Worksheets(ShtName).Cells(1, Columns.Count).End(xlToLeft).Column
        b = Application.Transpose(Worksheets(ShtName).Cells(1, 1).Resize(1, LCol).Value)
        
        LRow = Worksheets(ShtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        With ws1.Range("A2", ws1.Cells(Rows.Count, "I").End(xlUp))
            .AutoFilter 3, ShtName
            If ws1.Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
                Set RngSrc = .Offset(1)
                With RngSrc
                    For j = LBound(b) To UBound(b)
                        If RngDest Is Nothing Then
                            Set RngDest = .Columns(b(j, 1))
                        Else
                            Set RngDest = Union(RngDest, .Columns(b(j, 1)))
                        End If
                    Next j
                    RngDest.Copy Worksheets(ShtName).Range("A" & LRow)
                    Set RngDest = Nothing
                End With
                .Offset(1).EntireRow.Delete
            End If
            .AutoFilter
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

Did post #6 provide you with the dynamic code you were after?

 

[Beginner001]

Definitely! Thank you!