VBA copy from single sheet with cell values as reference and paste to another workbook's multiple tabs following the tabs name

[rozek]

Hello. Appreciate if someone can help me. I have one sheet that contains rows of data as below:

Book1
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W1	1/8/2021	10	good	Y
3
4	W2	2/8/2021	20	good	N
5
6	W3	5/8/2021	30	bad	Y
Sheet1

Another workbook with 3 tabs name W1, W2 & W3 which has some historical data.

Book2
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W1	1/5/2021	20	good	Y
3	W1	11/6/2021	30	good	Y
W1

Book2
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W2	3/2/2021	45	good	Y
3	W2	21/5/2021	80	good	Y
W2

Book2
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W3	1/1/2021	34	good	Y
3	W3	17/3/2021	100	good	Y
W3

The flow:
1. Select from source workbook data rows with column E (validity) values = "Y" only which are rows A2:E2 and A6:E6
2. Copy these row values
3. Paste accordingly to the tabs name in the destination workbook following the column names. IF cell name is W1, paste W1 row data into W1 sheet tab.
4. Repeat this process for other source workbooks.

The final product example for tab W1 as follows:

Book2.xlsm
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W1	1/5/2021	20	good	Y
3	W1	11/6/2021	30	good	Y
4	W1	1/8/2021	10	good	Y
W1

Tab W2 data is not available since does not meet criteria of validity = "Y"

W3 tab final product:

Book2.xlsm
	A	B	C	D	E
1	NAME	date	amount	remarks	validity
2	W3	1/1/2021	34	good	Y
3	W3	17/3/2021	100	good	Y
4	W3	5/8/2021	30	bad	Y
W3

To get the ball rolling, the not so complete vba code as follows:

Private Sub CommandButton1_Click()
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

'Select directory
Dim path As String
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear

Set Y = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
   
    .Title = "Select Source File"
    .Show
   
    If .SelectedItems.Count = 1 Then
        path1 = .SelectedItems(1)
    Else:
        GoTo Finish:
    End If
End With

Set Z = Workbooks.Open(path1)
Application.CutCopyMode = False
       
Set SCON = Y.Sheets("control")
SCON.Cells(6, 5) = path1


'Extract data
    Z.Activate
   
    ri = 1 'first row in source workbook
    rf = Z.Cells(Rows.Count).End(xlUp).Row 'last row in source workbook
    'rf = 6
    
    rout = Y.Sheets("W1")(Rows.Count).End(xlUp).Row   ' starting row in destination workbook for each well sheets
 
    For r = ri To rf
        to_copy = Z.Sheets("Sheet1").Columns(5) 'column E (validity)
        If to_copy = "Y" Then
           
            Y.Sheets("W1").Cells(rout, 1) = Z.Sheets("Sheet1").Cells(r, 1)     'Name
            Y.Sheets("W1").Cells(rout, 2) = Z.Sheets("Sheet1").Cells(r, 2)     'Date
            Y.Sheets("W1").Cells(rout, 3) = Z.Sheets("Sheet1").Cells(r, 3)      'Amount
            Y.Sheets("W1").Cells(rout, 4) = Z.Sheets("Sheet1").Cells(r, 4)     'remarks
            Y.Sheets("W1").Cells(rout, 5) = Z.Sheets("Sheet1").Cells(r, 5)    'validity
        
        End If
          rout = rout + 1
        'End If
    Next r

Z.Close

MsgBox "Completed!"

Finish:

End Sub

Thank you so much for your attention & appreciate any help.

 

[GWteB]

See if this is what you're after, code is supposed to be pasted in the destination workbook.

Sub rozek()

    Dim WbSrc  As Workbook, WbDest As Workbook
    Dim WsDest As Worksheet
    Dim arrIN  As Variant, arrOUT As Variant
    Dim i      As Long

    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xl??", 1
        .Filters.Add "All Files", "*.*", 2
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False

        .Title = "Select Source File"
        If .Show Then

            Application.ScreenUpdating = False

            Set WbSrc = Application.Workbooks.Open(.SelectedItems(1))
            Set WbDest = ThisWorkbook

            With WbSrc.Worksheets("Sheet1")             ' <<< change name of source sheet to suit
                arrIN = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
            End With

            For i = 1 To UBound(arrIN, 1)
                If Not IsEmpty(arrIN(i, 1)) Then
                    If arrIN(i, 5) = "Y" Then
                        On Error Resume Next
                        Set WsDest = WbDest.Worksheets(arrIN(i, 1))
                        On Error GoTo 0
                        If Not WsDest Is Nothing Then
                            arrOUT = Application.Index(arrIN, i, 0)
                            With WsDest
                                .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(1, UBound(arrIN, 2)).Value = arrOUT
                            End With
                        End If
                    End If
                End If
            Next i
            WbSrc.Close SaveChanges:=False
            Application.ScreenUpdating = True

            MsgBox "Completed!", vbInformation
        Else
            MsgBox "Cancel was pressed, nothing was copied", vbExclamation
        End If
    End With
End Sub

 

[rozek]

See if this is what you're after, code is supposed to be pasted in the destination workbook.

Sub rozek()

    Dim WbSrc  As Workbook, WbDest As Workbook
    Dim WsDest As Worksheet
    Dim arrIN  As Variant, arrOUT As Variant
    Dim i      As Long

    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xl??", 1
        .Filters.Add "All Files", "*.*", 2
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False

        .Title = "Select Source File"
        If .Show Then

            Application.ScreenUpdating = False

            Set WbSrc = Application.Workbooks.Open(.SelectedItems(1))
            Set WbDest = ThisWorkbook

            With WbSrc.Worksheets("Sheet1")             ' <<< change name of source sheet to suit
                arrIN = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
            End With

            For i = 1 To UBound(arrIN, 1)
                If Not IsEmpty(arrIN(i, 1)) Then
                    If arrIN(i, 5) = "Y" Then
                        On Error Resume Next
                        Set WsDest = WbDest.Worksheets(arrIN(i, 1))
                        On Error GoTo 0
                        If Not WsDest Is Nothing Then
                            arrOUT = Application.Index(arrIN, i, 0)
                            With WsDest
                                .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(1, UBound(arrIN, 2)).Value = arrOUT
                            End With
                        End If
                    End If
                End If
            Next i
            WbSrc.Close SaveChanges:=False
            Application.ScreenUpdating = True

            MsgBox "Completed!", vbInformation
        Else
            MsgBox "Cancel was pressed, nothing was copied", vbExclamation
        End If
    End With
End Sub

[/QUOTE]

 

[rozek]

Thank you GWteB. It work! Awesome code.

The code copies the entire row and paste it to the destination sheet.

Where do you change the code if I want to copy only certain cells (column NAME,date,remarks,validity) in the row (from the same source column NAME,date,amount,remarks,validity) and paste it accordingly to the destination sheet (column C - amount is not selected). Should I use sheets.cells as to range? Thank you again.

Book2.xlsx
	A	B	C	D
1	NAME	date	remarks	validity
2	W1	1/5/2021	good	Y
3	W1	11/6/2021	good	Y
W1

 

[GWteB]

You are welcome.

I want to copy only certain cells. Should I use sheets.cells as to range?

That isn't a valid combination of objects, so such a statement cannot be used.
FYI, the Sheets object is a property of a single workbook and represents a collection of all the sheets (both worksheets and charts) within that particular workbook. It doesn't have a member named Cells. The Cells object is a property of a single worksheet and represents a range object containing all the cells on that worksheet.
It can sometimes be difficult to discover these kinds of things or to remember them at all, "things" by which I mean Excel's Object model hierarchy. While coding, the VBE mostly can guide you there with its built-in intellisense, provided it's enabled (menu > tools > options > general tab > auto list members). When you declare a variable of a certain type explicitly, intellisense pops up on typing the dot character, which can be really helpful.

So far, back to your project.
In general, it is not a good idea to have frequent repetitive read and write access to a worksheet, especially when it comes to a relatively large dataset. This is because a read action from (or a write action to) a large worksheet range takes (almost) as much time as such an action against a single cell. If the dataset can be read into the computer's memory in one go and after the necessary manipulations can also be written back to a worksheet in as few steps as possible, then that is preferable. That's exactly what my code does, summarized: read in the entire dataset at once (a VBA Array variable type is used for that), perform the check on "Y", determine whether the target worksheet exists and if so, write each data line to the worksheet at once.

Now that a column has to be omitted per data line to be written back, some additional manipulations in the computer's memory will have to take place in order to achieve the desired result but at the same time reduce the speed of the code as little as possible. That's what I've done with the code snippet below. Regarding the code from my post #2, replace this part

With WsDest
    .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(1, UBound(arrIN, 2)).Value = arrOUT
End With

with this part, and you should be ready to go.

arrOUT(3) = arrOUT(4)                           ' copy data on this particular row from array's 4th column one column to the left
arrOUT(4) = arrOUT(5)                           ' copy data on this particular row from array's 5th column one column to the left
ReDim Preserve arrOUT(1 To UBound(arrOUT) - 1)  ' cut off array's 5th column
With WsDest
    .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(1, UBound(arrOUT)).Value = arrOUT
End With