Loop +200 files, paste with Index, Match?

[M2909]

Guys,

I have this Loop which retreives a certain Range of data from each file.
This is the source: https://imgur.com/RqJL8Pt
Now i paste this this data in a masterfile by using below code.

Sub GetDataHalA()

'DECLARE AND SET VARIABLES

Dim wbk As Workbook
Dim Filename As String
Dim Path As String


Application.ScreenUpdating = False


Path = "W:\Operations Components\Manufactoring H\Heieinde\productie\dagrapport productie\output\Hal A\Output FY2019\"
Filename = Dir(Path & "*.xlsx")


Sheets("Outputdata").Select
ThisWorkbook.Sheets("Outputdata").Range("A1:CQ1048576").Select
    Selection.ClearContents


'--------------------------------------------
'OPEN EXCEL FILES
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(Path & Filename)
    Sheets("Weekoverzicht").Select
'Unprotect sheet
    ActiveSheet.Unprotect Password:="cirules"
'Copy data from source
    Range("a5:z29").SpecialCells(xlCellTypeVisible).Copy
'Paste data in Sheet 1
    ThisWorkbook.Sheets("Outputdata").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'Protect sheet again
    ActiveSheet.protect Password:="cirules"


'Prevents question for copy clipboard
    Application.CutCopyMode = False


'wbk.Close = don't save
    wbk.Close False
    Filename = Dir
Loop


End Sub

Then all data is pasted in the masterfile like this:
https://imgur.com/8ArbE89

It works ok, UNTILL something changes in the source data.
For example, looking at column M, this value has changed during the year, so therfore it would be best to start in a new column as soon as the header changes to BFT2.
An option could be to make a yearly template with all dates and machines fixed, and paste the data in the specific destination.

I'm really strugling to describe the situation as clearly as possible. sorry if it's not...

Hope you can help me out!

 

[Rijnsent]

Hi M2909,
what you than basically want to do after opening the file loop through the headers (from A7 down) and see if they match with row 2 in the totals file. I can spot you have weekly files that you aggregate intot a totals file? The method for this depends a bit on how often that changes and if changes are consistent (if an new line is inserted, whether it the line will than remain the day after it?). Could you elaborate a bit on that, how do the weekly files change?
Thanks,
Koen

 

[M2909]

Hi Koen, (ook Nederlands zie ik, mogen we hier in het Nederlands door gaan?)

Thanks for replying!

A machine can be added or deleted in a weekly file. This doesn't happen every week, but i want't the macro to be that smart when it happens it doesn't screw up all the data.
when a machine is added it starts that week. So all files before the change have 1 row data less. Therefore the copy range has to be flexible too.

In total we have 4 halls, where we will have 52 weekly files at the end of the year. A few changes can occur during the year but not even each month.

 

[Rijnsent]

Hi M2909,
got ya. (Ja, ben ook Nederlander, maar is een internationaal forum, vandaar een engels antwoord).
See some untested code below, this is hopefully a step towards solving your issue. I got rid of quite some .Select statements. They are normally from recorded macros, but they slow down macros and are rather inefficient. Having said that, the code below is not complete/finished, but hopefully gives you some pointers in the right direction. Go step-by-step through the code when you run it (with F8) and/or store a copy of your output file before you run it.
Cheers,
Koen

Sub GetDataHalA()

'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String

Application.ScreenUpdating = False

Path = "W:\Operations Components\Manufactoring H\Heieinde\productie\dagrapport productie\output\Hal A\Output FY2019\"
Filename = Dir(Path & "*.xlsx")

Set ActWb = ActiveWorkbook
Set OutSht = ActWb.Worksheets("Outputdata")
OutSht.Range("A1:CQ1048576").ClearContents

'--------------------------------------------
'OPEN EXCEL FILES
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(Path & Filename)
    Set InSht = wbk.Sheets("Weekoverzicht")
    'Unprotect sheet
    InSht.Unprotect Password:="cirules"

    'Check 1: do the headers match?
    'Sht A7 down
    'Outsht C2 right
    HeadersMatch = True
    MaxInRw = InSht.Range("A7").End(xlDown).Row
    MaxOutCol = OutSht.Range("C2").End(xlToRight).Column
    
    'Check for empty
    If MaxInRw = Rows.Count Then
        'Empty machines list in weekly, do not process file
        HeadersMatch = False
    Else
        'Filled list in weekly
        For InRw = 7 To MaxInRw
            'Match all, one by one, fail if one is mismatching
            If InSht.Cells(InRw, 1).Value <> OutSht.Cells(2, InRw - 4).Value Then
                HeadersMatch = False
                Exit For
            End If
        Next InRw
    End If
    
    
    If HeadersMatch = True Then
        'Copy data from source
        InSht.Range("A5:Z29").SpecialCells(xlCellTypeVisible).Copy
        'Paste data in Sheet 1
        OutSht.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        'Protect sheet again - no need: you close the file without saving
        'ActiveSheet.Protect Password:="cirules"
        'Prevents question for copy clipboard
        Application.CutCopyMode = False
    Else
        'Headers mismatch, do them one by one, inserting machines on the fly
        
        For InRw = 7 To MaxInRw
            'Match all, one by one
            For OutCol = 3 To MaxOutCol
                ColCopied = False
                If InSht.Cells(InRw, 1).Value = OutSht.Cells(2, OutCol).Value Then
                    'Found match, copy-paste
                    InSht.Range("A" & InRw & ":Z" & InRw).SpecialCells(xlCellTypeVisible).Copy
                    'Paste data in Sheet 1
                    OutSht.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                    'Protect sheet again - no need: you close the file without saving
                    'ActiveSheet.Protect Password:="cirules"
                    'Prevents question for copy clipboard
                    Application.CutCopyMode = False
                    ColCopied = True
                    Exit For
                End If
            Next OutCol
            If ColCopied = False Then
                'New machine, put it somewhere at the end of the data?
                
            End If
        Next InRw
    End If

    'wbk.Close = don't save
    wbk.Close False
    Filename = Dir
Loop


End Sub

 

[M2909]

Thank you Koen.

Next couple of days i have planned to work on the file, keep you posted!

Mark