How to loop the macro

[martinus1988]

Hi all,

I worked my way around this macro. What is does is that is will open an xlsx, copy all the data and drops it in a specific sheet inside the workbook.
The path of the file to copy is in column H.
The Sheet name of the to be pasted data is in column I.

Now i am looking for a way to loop from H2 to H99 (with the correct sheets names in I2-I99)
Can someone help me.

Sub openAndCopyPartlist()
    Dim wbCopy As Workbook
    Dim wsCopy As Worksheet
    Dim rngCopy As Range
    Dim wbPaste As Workbook
    Dim wsPaste As Worksheet
    Dim rngPaste As Range
    
    Set wbCopy = Workbooks.Open(ThisWorkbook.Sheets("Master").Range("H2").Value) 'This is Path location C:\\.....xlsx
    Set wsCopy = wbCopy.Worksheets("Blad1") 'Is name of Sheet1
    Set rngCopy = wsCopy.Range("a1:m100").EntireColumn 'Is range to copy
    Set wbPaste = Workbooks("Voorraad beheer.xlsm") 'Is name of the paste location (workbook name)
    Set wsPaste = wbPaste.Worksheets(ThisWorkbook.Sheets("Master").Range("I2").Value)  'This is Path location for the sheet. like test.
    Set rngPaste = wsPaste.Range("a1")  'Past at cell 1
    
    rngCopy.Copy
    rngPaste.PasteSpecial
    wbCopy.Close savechanges:=False
    
    'now i am looking for a way to do this for the complete list H2 to H99 for sheet names: I2 to I99.
    ' Can someone help me how to make it a loop?
    
End Sub

 

[mrmmickle1]

Try This:

[COLOR=#0000ff][B]Sub[/B][/COLOR] openAndCopyPartlist()

    [COLOR=#0000ff][B]Dim[/B][/COLOR] wbCopy [COLOR=#0000ff][B]As[/B][/COLOR] Workbook
    Dim wsCopy[COLOR=#0000ff][B] As [/B][/COLOR]Worksheet
    Dim rngCopy [COLOR=#0000ff][B]As [/B][/COLOR]Range
    Dim wbPaste[COLOR=#0000ff][B] As[/B][/COLOR] Workbook
    Dim wsPaste [COLOR=#0000ff][B]As [/B][/COLOR]Worksheet
    Dim rngPaste [COLOR=#0000ff][B]As [/B][/COLOR]Range
   [B][COLOR=#0000ff] Dim[/COLOR][/B] IntLp [COLOR=#0000ff][B]As Integer[/B][/COLOR]
    
[COLOR=#0000ff][B]    For[/B][/COLOR] IntLp = 2 [COLOR=#0000ff][B]To[/B][/COLOR] 99

   [COLOR=#0000ff][B] Set[/B][/COLOR] wbCopy = Workbooks.Open(ThisWorkbook.Sheets("Master").Range("H" & IntLp).Value) 
    [COLOR=#0000ff][B]Set[/B][/COLOR] wsCopy = wbCopy.Worksheets("Blad1") 
 [COLOR=#0000ff][B]   Set[/B][/COLOR] rngCopy = wsCopy.Range("a1:m100").EntireColumn
[COLOR=#0000ff][B]    Set[/B][/COLOR] wbPaste = Workbooks("Voorraad beheer.xlsm")
  [COLOR=#0000ff][B]  Set[/B][/COLOR] wsPaste = wbPaste.Worksheets(ThisWorkbook.Sheets("Master").Range("I" & IntLp).Value) 
[COLOR=#0000ff][B]    Set[/B][/COLOR] rngPaste = wsPaste.Range("a1")  
    
    rngCopy.Copy
    rngPaste.PasteSpecial
    wbCopy.Close savechanges:=[COLOR=#0000ff][B]False[/B][/COLOR]

 [COLOR=#0000ff][B]   Next [/B][/COLOR]IntLp
 [B][COLOR=#008000]   [/COLOR][/B]
[COLOR=#0000ff][B]End Sub[/B][/COLOR]

 

[martinus1988]

Wow thank you! The macro is almost perfect. I have 2 issues remaining, do you know the awnser?

Sub openAndCopyPartlist()

    Dim wbCopy As Workbook
    Dim wsCopy As Worksheet
    Dim rngCopy As Range
    Dim wbPaste As Workbook
    Dim wsPaste As Worksheet
    Dim rngPaste As Range
    Dim IntLp As Integer
    
    For IntLp = 2 To 99 'gives an error because i dont have 99 but 17 lines. So ho can this be:
    ' For IntLp = 2 To Rownumber H (last row with data)
    
'The other problem that i encounter is that i get a Excel popup that there is to much data on the copyboard or something. Get that message each copy past row... so kinda annoying.

    Set wbCopy = Workbooks.Open(ThisWorkbook.Sheets("Master").Range("H" & IntLp).Value)
    Set wsCopy = wbCopy.Worksheets("Blad1")
    Set rngCopy = wsCopy.Range("a1:m100").EntireColumn
    Set wbPaste = Workbooks("Voorraad beheer.xlsm")
    Set wsPaste = wbPaste.Worksheets(ThisWorkbook.Sheets("Master").Range("I" & IntLp).Value)
    Set rngPaste = wsPaste.Range("a1")
    
    rngCopy.Copy
    rngPaste.PasteSpecial
    wbCopy.Close savechanges:=False

    Next IntLp
 
End Sub

 

[martinus1988]

For IntLp = 2 To 99 'gives an error because i dont have 99 but 17 lines. So ho can this be:
' For IntLp = 2 To Rownumber H (last row with data)

'The other problem that i encounter is that i get a Excel popup that there is to much data on the copyboard or something. Get that message each copy past row... so kinda annoying.

 

[martinus1988]

Fixed the clipboard popup by adding a couple of lines. The last problem lies in the row count 2 to 99.

Sub openAndCopyPartlist()

    Dim wbCopy As Workbook
    Dim wsCopy As Worksheet
    Dim rngCopy As Range
    Dim wbPaste As Workbook
    Dim wsPaste As Worksheet
    Dim rngPaste As Range
    Dim IntLp As Integer
    
    For IntLp = 2 To 99 'gives an error because i dont have 99 but 17 lines. So ho can this be:
    ' For IntLp = 2 To Rownumber H (last row with data)
    
    Set wbCopy = Workbooks.Open(ThisWorkbook.Sheets("Master").Range("H" & IntLp).Value)
    Set wsCopy = wbCopy.Worksheets("Blad1")
    Set rngCopy = wsCopy.Range("a1:m100").EntireColumn
    Set wbPaste = Workbooks("Voorraad beheer.xlsm")
    Set wsPaste = wbPaste.Worksheets(ThisWorkbook.Sheets("Master").Range("I" & IntLp).Value)
    Set rngPaste = wsPaste.Range("a1")
    Application.DisplayAlerts = False
    
    
    rngCopy.Copy
    rngPaste.PasteSpecial
    wbCopy.Close savechanges:=False
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    
    Next IntLp
 
End Sub

 

[mrmmickle1]

Try This:

Application.DisplayAlerts = [COLOR=#0000ff][B]False[/B][/COLOR]

[B][COLOR=#008000]'Your Code[/COLOR][/B]

Application.DisplayAlerts = [COLOR=#0000ff][B]True[/B][/COLOR]

 

[martinus1988]

Done that and it works. Thank you.
Do you have any idea about my last question?

 

[mrmmickle1]

Try this:

[COLOR=#0000ff][B]Dim [/B][/COLOR]LRow[COLOR=#0000ff][B] As[/B][/COLOR] Integer

LRow = Cells(Rows.Count, "A").End(xlUp).Row
[COLOR=#0000ff][B]
For [/B][/COLOR]IntLp = 2 [COLOR=#0000ff][B]To[/B][/COLOR] LRow