Forum Discussion

Iron Contributor

May 07, 2024

Solved

VBA - Copying and pasting data from one document to another

Hello VBA experts,

Running Excel 365. A little bit of context:

I have an original Excel file named CBD Original. In this file, there is a range (B10:B25) with product references. For each reference that is "NE" and/or "N" my code opens the other excel file that is located in the same folder as the current Excel file and that is named "PBD Cliente", pastes data from CBD Original file based on some ranges that simulate the two different tabs of the PBD file and finally saves a copy of it.

I have already played around with the code in order to create this functionality. All you have to do is to put both attached files in a folder, open the CBD Original file and then run the macro.

The problem is the following: PBD file has its sheets protected. Specifically, blue "columns" are locked and values cannot be entered in those cells. I already know that (note that blue "columns" in the CBD Original file are empty because I know I should not paste any values there) but I do not know how to rearrange the code in order to understand that. As per now, the code simply copies row by row entirely and tries to paste it on the other file, which results breaking the whole automation because certain cells cannot be pasted (even if they are already blank). Run-time error 1004 occurs.

The attached PBD file does not have its sheet protected so that you can see the functionality working correctly. Please protect its sheets and make sure only blue columns are the ones unable to receive data when trying to propose a solution.

I hope anyone could give me a hand with this.

Martin

CBD Original.xlsm15 KB

PBD Cliente.xlsm10 KB

Closing and opening workbooks is relatively slow. Try this:

Sub TransferData()
    Dim CBDOriginalPath As String
    Dim PBDClientePath As String
    Dim CBDOriginalWB As Workbook
    Dim PBDClienteWB As Workbook
    Dim CBDOriginalWS As Worksheet
    Dim PBDClienteWS1 As Worksheet
    Dim PBDClienteWS2 As Worksheet
    Dim ProductRange As Range
    Dim LastRowCBDOriginal As Long
    Dim LastRowPBDCliente1 As Long
    Dim LastRowPBDCliente2 As Long
    Dim ProductRef As Range
    Dim CopyCounter As Integer
    Dim SourceRow1 As Range
    Dim SourceRow2 As Range
    Dim Destination1 As Range
    Dim Destination2 As Range

    Application.ScreenUpdating = False

    ' Get the paths of CBD Original and PBD Cliente files
    CBDOriginalPath = ThisWorkbook.Path & "\CBD Original.xlsm"
    PBDClientePath = ThisWorkbook.Path & "\PBD Cliente.xlsm"

    ' Open the workbooks
    Set CBDOriginalWB = Workbooks.Open(CBDOriginalPath)
    Set PBDClienteWB = Workbooks.Open(PBDClientePath)

    ' Set worksheets
    Set CBDOriginalWS = CBDOriginalWB.Sheets("Plantilla CBD")
    Set PBDClienteWS1 = PBDClienteWB.Sheets(CBDOriginalWS.Range("E8").Value)
    Set PBDClienteWS2 = PBDClienteWB.Sheets(CBDOriginalWS.Range("N8").Value)

    ' Find last row with data
    LastRowCBDOriginal = CBDOriginalWS.Cells(CBDOriginalWS.Rows.Count, "B").End(xlUp).Row
    ' Set product range
    Set ProductRange = CBDOriginalWS.Range("B10:B" & LastRowCBDOriginal)

    ' Initialize copy counter
    CopyCounter = 1

    ' Loop through product range to find "NE" or "N"
    For Each ProductRef In ProductRange
        If ProductRef.Value = "NE" Or ProductRef.Value = "N" Then
            ' Clear data rows from PBD sheets
            LastRowPBDCliente1 = PBDClienteWS1.Cells(PBDClienteWS1.Rows.Count, "B").End(xlUp).Row
            If LastRowPBDCliente1 >= 3 Then
                PBDClienteWS1.Range("B3:E" & LastRowPBDCliente1).ClearContents
                PBDClienteWS1.Range("H3:H" & LastRowPBDCliente1).ClearContents
            End If
            LastRowPBDCliente2 = PBDClienteWS2.Cells(PBDClienteWS2.Rows.Count, "B").End(xlUp).Row
            If LastRowPBDCliente2 >= 3 Then
                PBDClienteWS2.Range("B3:C" & LastRowPBDCliente2).ClearContents
                PBDClienteWS2.Range("F3:I" & LastRowPBDCliente2).ClearContents
            End If
            Set Destination1 = PBDClienteWS1.Range("B3")
            Set Destination2 = PBDClienteWS2.Range("B3")
        End If

        Set SourceRow1 = ProductRef.Offset(0, 3).Resize(1, 4)
        Set SourceRow2 = ProductRef.Offset(0, 9)
        If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
            ' Transfer data for Tab 1
            SourceRow1.Copy Destination:=Destination1
            SourceRow2.Copy Destination:=Destination1.Offset(0, 6)
            Set Destination1 = Destination1.Offset(1)
        End If

        Set SourceRow1 = ProductRef.Offset(0, 12).Resize(1, 2)
        Set SourceRow2 = ProductRef.Offset(0, 16).Resize(1, 4)
        If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
            ' Transfer data for Tab 2
            SourceRow1.Copy Destination:=Destination2
            SourceRow2.Copy Destination:=Destination2.Offset(0, 4)
            Set Destination2 = Destination2.Offset(1)
        End If

        Select Case ProductRef.Offset(1).Value
            Case "NE", "N", ""
                ' Save PBD Cliente workbook with unique name
                PBDClienteWB.SaveAs Filename:=ThisWorkbook.Path & "\PBD Cliente_" & Format(Now(), "yyyymmdd_hhmmss") & "_" & CopyCounter & ".xlsx", FileFormat:=51
                CopyCounter = CopyCounter + 1
        End Select
    Next ProductRef

    ' Close workbooks without saving changes
    CBDOriginalWB.Close SaveChanges:=False
    PBDClienteWB.Close SaveChanges:=False

    Application.ScreenUpdating = True

    MsgBox "Data transfer completed successfully.", vbInformation
End Sub

13 Replies

HansVogelaar

MVP

May 07, 2024

Martin_Angosto

I don't understand why you are using nested loops. Does this do what you want?

Sub TransferData()
    Dim CBDOriginalPath As String
    Dim PBDClientePath As String
    Dim CBDOriginalWB As Workbook
    Dim PBDClienteWB As Workbook
    Dim CBDOriginalWS As Worksheet
    Dim PBDClienteWS1 As Worksheet
    Dim PBDClienteWS2 As Worksheet
    Dim ProductRange As Range
    Dim LastRowPBDCliente1 As Long
    Dim LastRowPBDCliente2 As Long
    Dim ProductRef As Range
    Dim CopyCounter As Integer
    Dim DataRange As Range
    Dim SourceRow1 As Range
    Dim SourceRow2 As Range
    Dim Destination1 As Range
    Dim Destination2 As Range

    ' Get the paths of CBD Original and PBD Cliente files
    CBDOriginalPath = ThisWorkbook.Path & "\CBD Original.xlsm"
    PBDClientePath = ThisWorkbook.Path & "\PBD Cliente.xlsm"

    ' Open the workbooks
    Set CBDOriginalWB = Workbooks.Open(CBDOriginalPath)
    Set PBDClienteWB = Workbooks.Open(PBDClientePath)

    ' Set worksheets
    Set CBDOriginalWS = CBDOriginalWB.Sheets("Plantilla CBD")
    Set PBDClienteWS1 = PBDClienteWB.Sheets(CBDOriginalWS.Range("E8").Value)
    Set PBDClienteWS2 = PBDClienteWB.Sheets(CBDOriginalWS.Range("N8").Value)
    ' Find last rows with data
    LastRowPBDCliente1 = PBDClienteWS1.Cells(PBDClienteWS1.Rows.Count, "B").End(xlUp).Row
    LastRowPBDCliente2 = PBDClienteWS2.Cells(PBDClienteWS2.Rows.Count, "B").End(xlUp).Row

    ' Set product range
    Set ProductRange = CBDOriginalWS.Range("B10:B25")

    ' Initialize copy counter
    CopyCounter = 1

    ' Loop through product range to find "NE" or "N"
    For Each ProductRef In ProductRange
        If ProductRef.Value = "NE" Or ProductRef.Value = "N" Then
            Set SourceRow1 = ProductRef.Offset(0, 3).Resize(1, 4)
            Set SourceRow2 = ProductRef.Offset(0, 9)
            If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
                ' Transfer data for Tab 1
                LastRowPBDCliente1 = LastRowPBDCliente1 + 1
                Set Destination1 = PBDClienteWS1.Range("B" & LastRowPBDCliente1)
                SourceRow1.Copy Destination:=Destination1
                SourceRow2.Copy Destination:=Destination1.Offset(0, 6)
            End If

            Set SourceRow1 = ProductRef.Offset(0, 13).Resize(1, 2)
            Set SourceRow2 = ProductRef.Offset(0, 17).Resize(1, 4)
            If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
                ' Transfer data for Tab 2
                LastRowPBDCliente2 = LastRowPBDCliente2 + 1
                Set Destination2 = PBDClienteWS2.Range("B" & LastRowPBDCliente2)
                SourceRow1.Copy Destination:=Destination2
                SourceRow2.Copy Destination:=Destination2.Offset(0, 4)
            End If

            ' Save PBD Cliente workbook with unique name
            PBDClienteWB.SaveAs Filename:=ThisWorkbook.Path & "\PBD Cliente_" & Format(Now(), "yyyymmdd_hhmmss") & "_" & CopyCounter & ".xlsx", FileFormat:=51
            CopyCounter = CopyCounter + 1
        End If
    Next ProductRef

    ' Close workbooks without saving changes
    CBDOriginalWB.Close False
    PBDClienteWB.Close True

    MsgBox "Data transfer completed successfully."
End Sub

Martin_Angosto

Iron Contributor

May 07, 2024

HansVogelaar

My knowledge of VBA is limited to kindly understand code and edit it when necessary + writing simple VBA. So I used AI to set up a basis for this. I then started to play around. The nested loop is for 1) do the whole procedure as many times as "N" or "NE" is found in the product reference range and 2) look through every single row in each of the two data ranges, find non-blank rows and then continue with the procedure of copying and pasting. My intention also was to paste all rows consecutively (see first picture I will attach) and not with empty spaces like in CBD file.

I have tried your code and it does not return any error (even if I protect the sheets of PBD file, which at least seems advancement). The thing is that the output is, to my great regret, nowhere near the desired. Have you run my code without protecting the sheets of PBD, just as they are attached? The output looks as follows (for instance, for the blue tab):

Which perfectly matches the structure and is in line with the CBD Original file:

However, with your proposal:

Note that Part Name in the first row should be "This" and not "123".

Any other suggestions? Am I getting something wrong?

HansVogelaar

MVP

May 07, 2024

Martin_Angosto

My apologies, I used an incorrect offset.

Sub TransferData()
    Dim CBDOriginalPath As String
    Dim PBDClientePath As String
    Dim CBDOriginalWB As Workbook
    Dim PBDClienteWB As Workbook
    Dim CBDOriginalWS As Worksheet
    Dim PBDClienteWS1 As Worksheet
    Dim PBDClienteWS2 As Worksheet
    Dim ProductRange As Range
    Dim LastRowPBDCliente1 As Long
    Dim LastRowPBDCliente2 As Long
    Dim ProductRef As Range
    Dim CopyCounter As Integer
    Dim DataRange As Range
    Dim SourceRow1 As Range
    Dim SourceRow2 As Range
    Dim Destination1 As Range
    Dim Destination2 As Range

    ' Get the paths of CBD Original and PBD Cliente files
    CBDOriginalPath = ThisWorkbook.Path & "\CBD Original.xlsm"
    PBDClientePath = ThisWorkbook.Path & "\PBD Cliente.xlsm"

    ' Open the workbooks
    Set CBDOriginalWB = Workbooks.Open(CBDOriginalPath)
    Set PBDClienteWB = Workbooks.Open(PBDClientePath)

    ' Set worksheets
    Set CBDOriginalWS = CBDOriginalWB.Sheets("Plantilla CBD")
    Set PBDClienteWS1 = PBDClienteWB.Sheets(CBDOriginalWS.Range("E8").Value)
    Set PBDClienteWS2 = PBDClienteWB.Sheets(CBDOriginalWS.Range("N8").Value)
    ' Find last rows with data
    LastRowPBDCliente1 = PBDClienteWS1.Cells(PBDClienteWS1.Rows.Count, "B").End(xlUp).Row
    LastRowPBDCliente2 = PBDClienteWS2.Cells(PBDClienteWS2.Rows.Count, "B").End(xlUp).Row

    ' Set product range
    Set ProductRange = CBDOriginalWS.Range("B10:B25")

    ' Initialize copy counter
    CopyCounter = 1

    ' Loop through product range to find "NE" or "N"
    For Each ProductRef In ProductRange
        If ProductRef.Value = "NE" Or ProductRef.Value = "N" Then
            Set SourceRow1 = ProductRef.Offset(0, 3).Resize(1, 4)
            Set SourceRow2 = ProductRef.Offset(0, 9)
            If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
                ' Transfer data for Tab 1
                LastRowPBDCliente1 = LastRowPBDCliente1 + 1
                Set Destination1 = PBDClienteWS1.Range("B" & LastRowPBDCliente1)
                SourceRow1.Copy Destination:=Destination1
                SourceRow2.Copy Destination:=Destination1.Offset(0, 6)
            End If

            Set SourceRow1 = ProductRef.Offset(0, 12).Resize(1, 2)
            Set SourceRow2 = ProductRef.Offset(0, 16).Resize(1, 4)
            If WorksheetFunction.CountA(Union(SourceRow1, SourceRow2)) > 0 Then
                ' Transfer data for Tab 2
                LastRowPBDCliente2 = LastRowPBDCliente2 + 1
                Set Destination2 = PBDClienteWS2.Range("B" & LastRowPBDCliente2)
                SourceRow1.Copy Destination:=Destination2
                SourceRow2.Copy Destination:=Destination2.Offset(0, 4)
            End If

            ' Save PBD Cliente workbook with unique name
            PBDClienteWB.SaveAs Filename:=ThisWorkbook.Path & "\PBD Cliente_" & Format(Now(), "yyyymmdd_hhmmss") & "_" & CopyCounter & ".xlsx", FileFormat:=51
            CopyCounter = CopyCounter + 1
        End If
    Next ProductRef

    ' Close workbooks without saving changes
    'CBDOriginalWB.Close False
    'PBDClienteWB.Close True

    MsgBox "Data transfer completed successfully."
End Sub