Solved: Loop all columns, sheets, files in folder and copy cells

[peterlar]

This code loops through all columns of all sheets of all files in a folder.

The copy paste for the individual cells works OK

My problem is twofold (file name and sheet name) for the paste result in "Loop Folder .xls":

1. All the sheet names paste once consecutively downwards in Column B but I want blank rows in between them as the loop goes through each column of the sheet.

2. I haven't been able to figure out how to loop the file names without getting a variety of error messages. I left the code to show the pasting the first file name to Column A and left it at that.




Sub testloop()
Dim Mypath As String, excelfile As Variant, i As Integer

Mypath = "N:\September 2006\" ' folder where all excel files reside
excelfile = Dir(Mypath & "*.xls")
Application.DisplayAlerts = False

Range("A2").Offset(1).Value = excelfile ' this pastes only the first file name

Do While excelfile <> "" ' loop all files
Set wbopen = Workbooks.Open(Filename:=Mypath & excelfile, UpdateLinks:=0) ' prevents Update Link message
excelfile = Dir

With wbopen
For i = 2 To .Sheets.Count ' loop sheets starting at sheet 2

'copies the source cells from each column of each sheet
.Sheets(i).Range("C5", .Sheets(i).Range("IV5").End(xlToLeft)).Copy
Workbooks("Loop Folder.xls").Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Offset(2).PasteSpecial Transpose:=True

' pastes the name of each sheet with no blank rows
' should skip through the number of columns before pasting next sheet name

ThisWorkbook.Sheets(1).Range("B65536").End(xlUp)(2, 1) = .Sheets(i).Name

Next i
.Close


End With

Loop
Application.DisplayAlerts = True


End Sub



Any help would be appreciated even if each row contains the file name and sheet name without any blank rows in Column A and Column B.

I am pretty new to vba and stumbled upon this forum recently as I struggle to learn.

Thanks

[peterlar]

This now works

My final code



Sub WorkOnHand()

Dim i As Long
Dim lr As Long
Dim ws As Worksheet
Dim mypath As String
Dim excelfile As String


Application.DisplayAlerts = False

'Turn off screen refresh for speed
Application.ScreenUpdating = False

mypath = "E:\September 2006\" ' folder where all excel files reside
excelfile = Dir(mypath & "*.xls")

'Set variable to save typing!
Set ws = Workbooks("Book1.xls").Sheets("Sheet1")

Do While excelfile <> "" ' loop all files
Set wbopen = Workbooks.Open(Filename:=mypath & excelfile, UpdateLinks:=0) ' prevents Update Link message
excelfile = Dir

'Get last row
lr = ws.UsedRange.Rows.Count

If lr > 1 Then
lr = lr + 2 'Add 2 for a space
End If

'Put workbook name in col A
ws.Cells(lr, 1) = wbopen.Name

With wbopen
For i = 2 To .Sheets.Count ' loop sheets starting at sheet 2

'Get last row
lr = ws.UsedRange.Rows.Count

'Add a space
If lr > 1 And i > 2 Then
lr = lr + 2
End If

'Put sheet name in Col B
ws.Cells(lr, 2) = .Sheets(i).Name

' populate the required cells

.Sheets(i).Range("C5", .Sheets(i).Range("IV5").End(xlToLeft)).Copy
ws.Range("C" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C16", .Sheets(i).Range("IV16").End(xlToLeft)).Copy
ws.Range("D" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C29", .Sheets(i).Range("IV29").End(xlToLeft)).Copy
ws.Range("E" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C33", .Sheets(i).Range("IV33").End(xlToLeft)).Copy
ws.Range("F" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C61", .Sheets(i).Range("IV61").End(xlToLeft)).Copy
ws.Range("G" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C20", .Sheets(i).Range("IV20").End(xlToLeft)).Copy
ws.Range("H" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C42", .Sheets(i).Range("IV42").End(xlToLeft)).Copy
ws.Range("I" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C24", .Sheets(i).Range("IV24").End(xlToLeft)).Copy
ws.Range("J" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C25", .Sheets(i).Range("IV25").End(xlToLeft)).Copy
ws.Range("K" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C45", .Sheets(i).Range("IV45").End(xlToLeft)).Copy
ws.Range("L" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C56", .Sheets(i).Range("IV56").End(xlToLeft)).Copy
ws.Range("M" & lr).PasteSpecial Transpose:=True

.Sheets(i).Range("C57", .Sheets(i).Range("IV57").End(xlToLeft)).Copy
ws.Range("N" & lr).PasteSpecial Transpose:=True

Next i
.Close
End With
Loop

Application.DisplayAlerts = True

'Turn on screen refresh
Application.ScreenUpdating = True

End Sub






Thanks anyways