Macro tbv importeren op basis van voorwaarde

[nikos84]

Beste,

Ik heb jullie forum uitgebreid doorgespit, maar geen antwoord op onderstaande kunnen vinden.
Ik heb een rits met excel files die bestaat uit initialen en cijfers bijv AB 200 104 (inhoud van deze file is één sheet met data, waar ik de kleur en format van wil behouden). Deze staan in één map allemaal bijelkaar
Vervolgens zou ik graag een macro maken die per unieke initiaal alle files van deze initiaal importeert per file per tabblad. Dat je dus één nieuwe file krijgt van AB met al zijn/haar tabbladen en deze dan in een nieuwe file opslaan en dit per unieke initiaal.

 

[Timshel]

Dit gaat waarschijnlijk niet in een keer goed, maar probeer deze macro eens.
Ik veronderstel dat alle bron- en doelbestanden de extensie .xlsx hebben danwel moeten krijgen.
Vergeet niet het pad aan te passen.

Option Explicit

Const Pad = "C:\Users\Public\Documents\Split\"

Sub VoegSamen()
    Dim ScName
    Dim BstName
    Dim WbTg As Workbook
    Dim strOpenWb As String
      
    For Each ScName In Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & Pad & "*.xlsx"" /b/s").StdOut.ReadAll, vbCrLf)
        If Not ScName = "" Then
            With GetObject(ScName)
                BstName = Split(Replace(ScName, Pad, ""))(0)
                .Sheets(1).Name = Split(Replace(ScName, Pad, ""), ".")(0)
                If InStr(strOpenWb, "|" & BstName) = 0 Then
                    .Sheets(1).Copy
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & BstName & ".xlsx", 51
                    strOpenWb = strOpenWb & "|" & BstName
                Else
                    Set WbTg = Workbooks(BstName & ".xlsx")
                    .Sheets(1).Copy After:=WbTg.Sheets(WbTg.Sheets.Count)
                End If
                .Close 0
            End With
        End If
    Next
    For Each BstName In Split(Mid(strOpenWb, 2), "|")
        Workbooks(BstName & ".xlsx").Close 1
    Next
End Sub

 

[nikos84]

Dat gaat al vrij goed, een paar opmerkingen. De individuele initialen laten nu een bestandsnaam zien van dubbel xlsx dus, AA 111.xlsx.xlsx.
En er bestaan ook bestanden waar in plaats van spaties met een liggend streepje wordt gewerkt bijv AA_112.xslx.
En zou er ook een optie zijn om ze gelijk op te slaan, ipv open te laten staan na samenvoeging.

gr

 

[Timshel]

Kijk eens welke problemen je nog tegenkomt met onderstaande aanpassingen.
De uitvoerbestanden zijn nu van het type .xlsb.

Option Explicit

Const Pad = "C:\Users\Public\Documents\Split\"

Sub VoegSamen()
    Dim ScName, TgName
    Dim WbTg As Workbook
    Dim strOpenWb As String
      
    For Each ScName In Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & Pad & "*.xlsx"" /b").StdOut.ReadAll, vbCrLf)
        If Not ScName = "" Then
            TgName = Split(Replace(ScName, "_", " "))(0) & ".xlsb"
            With GetObject(Pad & "\" & ScName)
                .Sheets(1).Name = Split(ScName, ".")(0)
                If InStr(strOpenWb, "|" & TgName) = 0 Then
                    .Sheets(1).Copy
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & TgName, 50
                    strOpenWb = strOpenWb & "|" & TgName
                Else
                    Set WbTg = Workbooks(TgName)
                    .Sheets(1).Copy After:=WbTg.Sheets(WbTg.Sheets.Count)
                End If
                .Close 0
            End With
        End If
    Next
    For Each TgName In Split(Mid(strOpenWb, 2), "|")
        Workbooks(TgName).Close 1
    Next
End Sub

 

[nikos84]

Ge-wel-dig!! Hartelijk dank!