Sub Consolidate()
Dim a As Workbook
Dim b As Workbook
Dim x, y(), i&, j&, k&
Dim myPath As String
Dim filename As String
Dim wb As Workbook
Dim Fnum&
Set b = ThisWorkbook
myPath = "C:\Data"
If Right(myPath, 1) <> "\" Then myPath = myPath + "\"
filename = Dir(myPath & "*.xl*")
Fnum = 0
k = 0
Do While filename <> ""
Fnum = Fnum + 1
Application.ScreenUpdating = False
Set wb = Workbooks.Open(myPath & filename)
x = wb.Sheets("Sheet1").Range("B3").CurrentRegion.Value
ReDim y(1 To UBound(x, 1) * UBound(x, 2) * Fnum, 1 To 3)
For i = 2 To UBound(x, 1)
For j = 2 To UBound(x, 2)
k = k + 1
y(k, 1) = x(i, 1)
y(k, 2) = x(i, j)
y(k, 3) = x(1, j)
Next j
Next i
filename = Dir
wb.Close SaveChanges:=False
Loop
With b.Sheets("Consolidate")
.Range("A2").Resize(k, 3) = y()
.Columns.AutoFit
.Activate
End With
Application.ScreenUpdating = True
End Sub
Bookmarks