Hi All,

I have Folder named "Test" in my D: drive. this folder has many workbooks with different names. i want to open one by one workbook and copy some range like a2:z500 and paste it to a destination workbook. please help me!!

Try this codes, see how it fits you:
Sub Collect_Data() Dim DstWks2 As Worksheet Dim LastRow As Long Dim R As Long Dim SrcWkb As Workbook Dim StartRow As Long Dim wkbname As Variant Dim xlsFiles As Variant 'Starting column and row for the destination workbook C = 1 R = 1 'Set references to destination workbook worksheet objects Set DstWks1 = ThisWorkbook.Worksheets("Formdata") Set DstWks2 = ThisWorkbook.Worksheets("Formdata2") 'Starting row on source worksheet StartRow = 11 'Get the workbooks to open xlsFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True) Application.AskToUpdateLinks = False If VarType(xlsFiles) = vbBoolean Then Exit Sub 'Loop through each workbook and copy the data to this workbook For Each wkbname In xlsFiles Set SrcWkb = Workbooks.Open(Filename:=wkbname, ReadOnly:=True) LastRow = SrcWkb.Worksheets("Data").Cells(Rows.Count, "BG").End(xlUp).Row If LastRow >= StartRow Then With SrcWkb.Worksheets("Data") DstWks1.Cells(R, C).Resize(LastRow - StartRow + 1, 1).Value = _ .Range(.Cells(StartRow, "BG"), .Cells(LastRow, "BG")).Value End With End If LastRow = SrcWkb.Worksheets("Data").Cells(Rows.Count, "CB").End(xlUp).Row If LastRow >= StartRow Then With SrcWkb.Worksheets("Data") DstWks2.Cells(R, C).Resize(LastRow - StartRow + 1, 1).Value = _ .Range(.Cells(StartRow, "CB"), .Cells(LastRow, "CB")).Value End With End If C = C + 1 SrcWkb.Close savechanges:=False Next wkbname End Sub



or:

That looks bad...try again:
'Starting row on source worksheet
StartRow = 11

'Get the workbooks to open
xlsFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If VarType(xlsFiles) = vbBoolean Then Exit Sub

'Loop through each workbook and copy the data to this workbook
For Each wkbname In xlsFiles
Set SrcWkb = Workbooks.Open(FileName:=wkbname, ReadOnly:=True)
LastRow = SrcWkb.Worksheets("Data").Cells(Rows.Count, "BG").End(xlUp).Row
If LastRow >= StartRow Then
With SrcWkb.Worksheets("Data")
DstWks1.Cells(R, C).Resize(LastRow - StartRow + 1, 1).Value = _
.Range(.Cells(StartRow, "BG"), .Cells(LastRow, "BG")).Value
End With
End If
LastRow = SrcWkb.Worksheets("Data").Cells(Rows.Count, "CB").End(xlUp).Row
If LastRow >= StartRow Then
With SrcWkb.Worksheets("Data")
DstWks2.Cells(R, C).Resize(LastRow - StartRow + 1, 1).Value = _
.Range(.Cells(StartRow, "CG"), .Cells(LastRow, "CG")).Value
End With
End If
C = C + 1
SrcWkb.Close
Next wkbname

End Sub

see this one:


Sub RunCodeOnAllXLSFiles()
Dim i As Integer
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\MyDocuments\TestResults"
.FileType = msoFileTypeExcelWorkbooks

If .Execute > 0 Then 'Workbooks in folder
For i = 1 To .FoundFiles.Count 'Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(.FoundFiles(i))

'DO YOUR CODE HERE

Next i
End If


For i = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(.FoundFiles(i)) 'DO YOUR CODE HERE 'Close Workbook and Save changes, wbResults.Close SaveChanges:=True Next i
End With

On Error Goto 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub