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

rozek

New Member
Joined
Aug 11, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows
Hello. Appreciate if someone can help me. I have one sheet that contains rows of data as below:
Book1
ABCDE
1NAMEdateamountremarksvalidity
2W11/8/202110goodY
3
4W22/8/202120goodN
5
6W35/8/202130badY
Sheet1


Another workbook with 3 tabs name W1, W2 & W3 which has some historical data.
Book2
ABCDE
1NAMEdateamountremarksvalidity
2W11/5/202120goodY
3W111/6/202130goodY
W1

Book2
ABCDE
1NAMEdateamountremarksvalidity
2W23/2/202145goodY
3W221/5/202180goodY
W2

Book2
ABCDE
1NAMEdateamountremarksvalidity
2W31/1/202134goodY
3W317/3/2021100goodY
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
ABCDE
1NAMEdateamountremarksvalidity
2W11/5/202120goodY
3W111/6/202130goodY
4W11/8/202110goodY
W1


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

W3 tab final product:
Book2.xlsm
ABCDE
1NAMEdateamountremarksvalidity
2W31/1/202134goodY
3W317/3/2021100goodY
4W35/8/202130badY
W3


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

VBA Code:
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.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
See if this is what you're after, code is supposed to be pasted in the destination workbook.

VBA Code:
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
 
Upvote 0
See if this is what you're after, code is supposed to be pasted in the destination workbook.

VBA Code:
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]
 
Upvote 0
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
ABCD
1NAMEdateremarksvalidity
2W11/5/2021goodY
3W111/6/2021goodY
W1
 
Upvote 0
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.
ScreenShot206.jpg


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
Rich (BB code):
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.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top