jaevo
07-21-2014, 08:40 AM
I have below code, but does not work correctly. The problem is when it's run in main worksheet, it doesnt match the correct workbook and it only generates the data in first workbook for all worksheets. Any idea ? THX
Sub HzWb()
Dim bt As Range, r As Long, c As Long
r = 1
c = 8
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents
Application.ScreenUpdating = False
Dim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "\*.xlsm")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
Erow = Range("A1").CurrentRegion.Rows.Count + 1
fn = ThisWorkbook.Path & "\" & FileName
Set wb = GetObject(fn)
Set sht = wb.Worksheets(1)
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))
Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub HzWb()
Dim bt As Range, r As Long, c As Long
r = 1
c = 8
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents
Application.ScreenUpdating = False
Dim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "\*.xlsm")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
Erow = Range("A1").CurrentRegion.Rows.Count + 1
fn = ThisWorkbook.Path & "\" & FileName
Set wb = GetObject(fn)
Set sht = wb.Worksheets(1)
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))
Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub