PDA

View Full Version : Consolidate datas from workbooks to masterfile



EMRBR
06-07-2018, 01:04 PM
Hello,

I'm trying to code a macro which will open all the workbooks in a directory.
copy all the fields row or column (without the headers (row 1) main information are on the four first column.
Copy these rows to the masterfile below each other but keeping the same within sheet "Result". starting from A2
the headers will be on A1:G1

I've found a code but it copy everything on column A instead of keeping the original format.
and i'm tried to understand arrays but i'm blocking on it since yesterday :/


Sub test2() Dim Rng
Dim sht As Worksheet
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim ThisBk As Workbook
Dim Tgt As Range
Dim Arr, a
Dim c As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Arr = Array("Nome", "Hora", "Type", "DATA EVENTO")
Set ThisBk = ActiveWorkbook
Path = ThisBk.Path & "\"
Filename = Dir(Path & "*.xls*")
Do While Len(Filename) > 0
If Filename <> ThisWorkbook.Name Then
Set wbk = Workbooks.Open(Path & Filename, UpdateLinks:=False)
Call CopyNameClearSome
Call TimeFormat
Call SuspectEntries
For Each sht In wbk.Worksheets
For Each a In Arr
Set c = sht.Rows(1).Find(a)
If Not c Is Nothing Then
Set Tgt = ThisBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp)(2)
On Error Resume Next
Intersect(c.EntireColumn, sht.UsedRange).Copy Tgt
On Error GoTo 0
End If
Next a
Next sht
wbk.Close savechanges:=False
End If
Filename = Dir
Loop
On Error Resume Next
ThisBk.Sheets("Sheet1").Columns(1).SpecialCells(xlCellTypeBlanks).Delete
ThisBk.Sheets("Sheet1").Columns(1).SpecialCells(xlCellTypeConstants, xlErrors).Delete
On Error GoTo 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub