Copy Data from one Workbook to another

N

Negi1984

Board Regular
Joined
May 6, 2011
Messages
198
Hi All,

I have 2 different file and my goal is to copy data from 1 workbook from specific range and paste as value in other workbook in specific range. Normal copy paste I did by recording macro but unable to apply logic to solve with multiple conditions.

looking here for support. I have uploaded the sample file for example purpose in this link : https://1drv.ms/x/s!Ap80Ku6M2Tw5gUqvEuWR3VBUcMMG. Also highlighed ranges in yellow color which needs to copy and paste.

Conditions :-
1) In workbook 1 contains Sheet name "Table 1" from which I need to copy data.
2) WB 2 contains sheet name "Lista de Produtos_Instalar" in which I have to paste data.
3) Data Should be copy from next row as soon as cell contains "NOME" in column A.
4) Last range to copy data is one row above till column name Data as soon as cell contains "Gabinete "+Any number.
and if there is no "Gabinete" mentioned till last row of workbook 1 than just copy data till last row. 5) Now go to Workbook to sheet name "Lista de Produtos_Instalar" and search for work contains "NOME" in column A and paste the copied data , 1 row below the "NOME".

Note : Here not more issue , we need to paste in visible cells, any rows can be hidden. Also columns in where we are pasting data having merged cells.

6) Now again we need to repeat same copy paste steps if there is another cells contains word "NOME" in column A in workbook 1 and follow above steps 3 to 5 similarly.

Not sure I am able to explain it properly but I Hope by seeing rows highlighted in yellow in above given link will easily understandable.

Regards,
Rajender
 
Sort by date Sort by votes
Try this.
Put the following code in a new book.
The macro will ask you to open book1 and book2


Code: 
Sub Copy_Data()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim wbName1 As String, wbName2 As String
    Dim r As Range, b As Range, celda As String
    Dim lr1 As Long, lr2 As Long, ini As Long, fin As Long
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Pick workbook 1"
        .Filters.Add "Excel Files", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then Exit Sub
        wbName1 = .SelectedItems.Item(1)
        .Title = "Pick workbook 2"
        If Not .Show Then Exit Sub
        wbName2 = .SelectedItems.Item(1)
    End With
    
    Set wb1 = Workbooks.Open(wbName1)
    Set wb2 = Workbooks.Open(wbName2)
    
    Set sh1 = wb1.Sheets("Table 1")
    Set sh2 = wb2.Sheets("Lista de Produtos_Instalar")
    
    lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row
    Set r = sh1.Range("A:A")
    Set b = r.Find("Gabinete", LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            ini = b.Row
            fin = lr1
            For i = b.Row + 1 To lr1
                If LCase(Left(sh1.Cells(i, "A").Value, 4)) = LCase("NOME") Then
                    ini = i + 1
                End If
                If LCase(Left(sh1.Cells(i, "A").Value, 8)) = LCase("Gabinete") Then
                    fin = i - 1
                    Exit For
                End If
            Next
            
            For j = 1 To lr2
                If sh2.Cells(j, "B").Value = b.Value Then
                    ini2 = j
                    fin2 = lr2
                    For k = j + 1 To lr2
                        If LCase(Left(sh2.Cells(k, "B").Value, 4)) = LCase("NOME") Then
                            ini2 = k + 1
                        End If
                        If LCase(Left(sh2.Cells(k, "B").Value, 8)) = LCase("Gabinete") Then
                            fin2 = k - 1
                            Exit For
                        End If
                    Next
                End If
            Next
            
            For i = ini To fin
                For m = ini2 To fin2
                    If sh2.Cells(m, "B").EntireRow.Hidden = False Then
                        sh2.Cells(m, "B").Value = sh1.Cells(i, "A").Value
                        sh2.Cells(m, "K").Value = sh1.Cells(i, "B").Value
                        sh2.Cells(m, "R").Value = sh1.Cells(i, "C").Value
                        sh2.Cells(m, "T").Value = sh1.Cells(i, "D").Value
                        sh2.Cells(m, "AA").Value = sh1.Cells(i, "E").Value
                        sh2.Cells(m, "AD").Value = sh1.Cells(i, "F").Value
                        ini2 = m + 1
                        Exit For
                    End If
                Next
            Next
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If


    MsgBox "End"


End Sub
 
Upvote 0

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Hi Dante,

Thanks a ton for your support. Macro is almost working fine.
I thing I just noticed small thing In table 1 there is value mentioned "-7154" & "-7120601" in header name "NÚMERO DE SÉRIE "

and when it pasted in WB 2 in sheet " Lista de Produtos_Instalar " its showing as "##" due to column width size.
But where as I check the other text length which are greater than these numbers in same column are perfectly showing fine.

Can you Please suggest , How to fix this ?
Also if I want to run this code from WB2 and only want to open this file from folder than in which line I have to do modification ?
 
Upvote 0
So you only have bigger the width of the columns.

If you put the macro in book2, then open only the book1:

Code: 
Sub Copy_Data()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim wbName1 As String, wbName2 As String
    Dim r As Range, b As Range, celda As String
    Dim lr1 As Long, lr2 As Long, ini As Long, fin As Long
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Pick workbook 1"
        .Filters.Add "Excel Files", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then Exit Sub
[COLOR=#0000ff]        wbName1 = .SelectedItems.Item(1)[/COLOR]
    End With
    
    Set wb1 = Workbooks.Open(wbName1)
[COLOR=#0000ff]    Set wb2 = ThisWorkbook[/COLOR]
    
    Set sh1 = wb1.Sheets("Table 1")
    Set sh2 = wb2.Sheets("Lista de Produtos_Instalar")
    
    lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row
    Set r = sh1.Range("A:A")
    Set b = r.Find("Gabinete", LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            ini = b.Row
            fin = lr1
            For i = b.Row + 1 To lr1
                If LCase(Left(sh1.Cells(i, "A").Value, 4)) = LCase("NOME") Then
                    ini = i + 1
                End If
                If LCase(Left(sh1.Cells(i, "A").Value, 8)) = LCase("Gabinete") Then
                    fin = i - 1
                    Exit For
                End If
            Next
            
            For j = 1 To lr2
                If sh2.Cells(j, "B").Value = b.Value Then
                    ini2 = j
                    fin2 = lr2
                    For k = j + 1 To lr2
                        If LCase(Left(sh2.Cells(k, "B").Value, 4)) = LCase("NOME") Then
                            ini2 = k + 1
                        End If
                        If LCase(Left(sh2.Cells(k, "B").Value, 8)) = LCase("Gabinete") Then
                            fin2 = k - 1
                            Exit For
                        End If
                    Next
                End If
            Next
            
            For i = ini To fin
                For m = ini2 To fin2
                    If sh2.Cells(m, "B").EntireRow.Hidden = False Then
                        sh2.Cells(m, "B").Value = sh1.Cells(i, "A").Value
                        sh2.Cells(m, "K").Value = sh1.Cells(i, "B").Value
                        sh2.Cells(m, "R").Value = sh1.Cells(i, "C").Value
                        sh2.Cells(m, "T").Value = sh1.Cells(i, "D").Value
                        sh2.Cells(m, "AA").Value = sh1.Cells(i, "E").Value
                        sh2.Cells(m, "AD").Value = sh1.Cells(i, "F").Value
                        ini2 = m + 1
                        Exit For
                    End If
                Next
            Next
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If


    MsgBox "End"


End Sub
 
Upvote 0
Hi Dante,

Sorry to bother you once again. I was testing this macro in all the cases which I have found now. Macro is successfully working. Now I only looking to add one more condition before this macro. Could you please suggest for the same.

Condition : If in Workbook 1 any column is merge in range A:K then before running the macro provided by you. first it should unmerge the columns and delete the columns which are completely blank in range A:K.

Thanks once again for your support.




DanteAmor said:
Try this.
Put the following code in a new book.
The macro will ask you to open book1 and book2


Code: 
Sub Copy_Data()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim wbName1 As String, wbName2 As String
    Dim r As Range, b As Range, celda As String
    Dim lr1 As Long, lr2 As Long, ini As Long, fin As Long
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Pick workbook 1"
        .Filters.Add "Excel Files", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If Not .Show Then Exit Sub
        wbName1 = .SelectedItems.Item(1)
        .Title = "Pick workbook 2"
        If Not .Show Then Exit Sub
        wbName2 = .SelectedItems.Item(1)
    End With
    
    Set wb1 = Workbooks.Open(wbName1)
    Set wb2 = Workbooks.Open(wbName2)
    
    Set sh1 = wb1.Sheets("Table 1")
    Set sh2 = wb2.Sheets("Lista de Produtos_Instalar")
    
    lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row
    Set r = sh1.Range("A:A")
    Set b = r.Find("Gabinete", LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            ini = b.Row
            fin = lr1
            For i = b.Row + 1 To lr1
                If LCase(Left(sh1.Cells(i, "A").Value, 4)) = LCase("NOME") Then
                    ini = i + 1
                End If
                If LCase(Left(sh1.Cells(i, "A").Value, 8)) = LCase("Gabinete") Then
                    fin = i - 1
                    Exit For
                End If
            Next
            
            For j = 1 To lr2
                If sh2.Cells(j, "B").Value = b.Value Then
                    ini2 = j
                    fin2 = lr2
                    For k = j + 1 To lr2
                        If LCase(Left(sh2.Cells(k, "B").Value, 4)) = LCase("NOME") Then
                            ini2 = k + 1
                        End If
                        If LCase(Left(sh2.Cells(k, "B").Value, 8)) = LCase("Gabinete") Then
                            fin2 = k - 1
                            Exit For
                        End If
                    Next
                End If
            Next
            
            For i = ini To fin
                For m = ini2 To fin2
                    If sh2.Cells(m, "B").EntireRow.Hidden = False Then
                        sh2.Cells(m, "B").Value = sh1.Cells(i, "A").Value
                        sh2.Cells(m, "K").Value = sh1.Cells(i, "B").Value
                        sh2.Cells(m, "R").Value = sh1.Cells(i, "C").Value
                        sh2.Cells(m, "T").Value = sh1.Cells(i, "D").Value
                        sh2.Cells(m, "AA").Value = sh1.Cells(i, "E").Value
                        sh2.Cells(m, "AD").Value = sh1.Cells(i, "F").Value
                        ini2 = m + 1
                        Exit For
                    End If
                Next
            Next
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If


    MsgBox "End"


End Sub
Click to expand...
 
Upvote 0
The recommendation of the merge cells is to show the information in a beautiful way, not for a database. You must process those cells manually.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Copy & Paste from workbook to another with criterias
Replies
2
Views
140
Anthony86
A
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
229
Insurance Dave
I
B
  • Question
VBA Macro Not Detecting Slicer Correctly in Excel Workbook
Replies
0
Views
278
bigodudo
B
T
  • Solved
Copy and Past the Data from Multiple Closed Workbooks
2
Replies
16
Views
895
thespardian
T
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
157
kizzie37
K

Forum statistics

Threads
1,214,987
Messages
6,122,613
Members
449,090
Latest member
vivek chauhan

Share this page

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