Macro om Excel lijst te splitsen naar meerdere Excel bestanden

[Khalid23]

Hallo,
Ik gebruik deze macro voor het maken van sheets per bedrijf.
Nu wil ik dat macro het excel bestand splitst naar meerdere bestanden per leverancier en deze opslaat in folder X.
De filenaam moet dan zijn : Naam_creatiedatum
Wie kan mij helpen
Alvast bedankt

Sub tsh()
    Dim Br, Bq, Bs
    Dim i As Long
    
    Br = Sheets("Blad1").Cells(1).CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(Br)
            .Item(Br(i, 1)) = .Item(Br(i, 1)) & "|" & i
        Next
        For Each Bq In .Keys
            Workbook.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Bq
            Sheets("Blad1").Range("A1:D1").Copy Range("A1")
            Bs = Application.Transpose(Split(Mid(.Item(Bq), 2), "|"))
            Cells(2, 1).Resize(UBound(Bs), 4) = Application.Index(Br, Bs, [column(A:D)])
            Range("A1:D1").EntireColumn.AutoFit
        Next
     End With
End Sub

 

[Timshel]

Is 'bedrijf' hetzelfde als 'leverancier'?
Hoe moeten de gegevens gesplitst worden als er meerdere bestanden per leverancier worden gemaakt?
Vaag!

 

[Khalid23]

Hallo,
Bedankt voor de snelle reactie.
Ik heb een nieuwe bestand toegevoegd met daarin de leveranciers in "Blad2".
Het bedrijf is hetzelfde als leverancier.
Wat ik eigenlijk wil is dat de macro bestanden gaat maken per leverancier.(kolom A) en 1 bestand per leverancier
En dat de macro alleen bestanden gaat maken van leverancier die in “Blad2” voorkomen.
Dus : de macro moet dan 4 bestanden maken van onderstaande leveranciers,
Henk BV
Henk BV
Jansen NV
Klaassen VOF

alvast bedankt

 

[Timshel]

Wat betekent het dat Henk BV twee keer in het lijstje staat? Dat wordt twee keer hetzelfde bestand.

 

[Khalid23]

Wat betekent het dat Henk BV twee keer in het lijstje staat? Dat wordt twee keer hetzelfde bestand.

Oh sorry foutje. de leverancier in "blad2" komt een keer voor

 

[VenA]

Een optie

Sub VenA()
  Dim c00 As String, j As Long, ar
  c00 = "E:\temp\"
  ar = Sheets("Blad2").Columns(1).SpecialCells(2)
  Application.ScreenUpdating = False
  For j = 2 To UBound(ar)
    With Workbooks.Add
      Sheets(1).Cells(1, 26).Resize(2) = Application.Transpose(Array(ar(1, 1), ar(j, 1)))
      ThisWorkbook.Sheets("Blad1").Range("Table1[#All]").AdvancedFilter xlFilterCopy, Range("Z1:Z2"), Range("A1")
      Range("Z1:Z2").Clear
      Columns.AutoFit
      .SaveAs c00 & ar(j, 1) & Format(Now, "_yyyymmdd-hhmmss"), 51
      .Close 0
    End With
  Next j
End Sub

 

[Khalid23]

Een optie

Sub VenA()
  Dim c00 As String, j As Long, ar
  c00 = "E:\temp\"
  ar = Sheets("Blad2").Columns(1).SpecialCells(2)
  Application.ScreenUpdating = False
  For j = 2 To UBound(ar)
    With Workbooks.Add
      Sheets(1).Cells(1, 26).Resize(2) = Application.Transpose(Array(ar(1, 1), ar(j, 1)))
      ThisWorkbook.Sheets("Blad1").Range("Table1[#All]").AdvancedFilter xlFilterCopy, Range("Z1:Z2"), Range("A1")
      Range("Z1:Z2").Clear
      Columns.AutoFit
      .SaveAs c00 & ar(j, 1) & Format(Now, "_yyyymmdd-hhmmss"), 51
      .Close 0
    End With
  Next j
End Sub

Heel erg bedankt. dit precies wat ik wilde.

 

[Khalid23]

Heel erg bedankt. dit precies wat ik wilde.

Hi,

De macro werkt wel goed en doet precies wat ik wil.
Nu wil eigenlijk dat macro hetzelfde doet (dus splitsen van bestanden) in een andere werkmap dan de macrofile. Dat heb ik geprobeerd maar het is mij niet gelukt
Ik heb twee files toegevoegd.
Macrofile: Daar staat de macro
Bestand Bestellingen : daar staat de data die gesplitst moet worden in tabblad “Bestellingen”. De leveranciers staan in tabblad “Leveranciers”

Ik hoop dat je mij kan helpen

Alvast bedankt

 

[Khalid23]

Hierbij de files

 

[Khalid23]

Kan iemand misschien mij helpen!
Onderstaande macro werkt wel maar de inhoud van de gecreëerde bestanden klopt niet.
De macro maakt gwn een kopie van het bronbestand en dat is niet de bedoeling
Mijn dank is groot

Sub VenA()
  Dim c00 As String, j As Long, ar
  c00 = "E:\temp\"
  ar = Sheets("Blad2").Columns(1).SpecialCells(2)
  Application.ScreenUpdating = False
  For j = 2 To UBound(ar)
    With Workbooks.Add
      Sheets(1).Cells(1, 26).Resize(2) = Application.Transpose(Array(ar(1, 1), ar(j, 1)))
      ThisWorkbook.Sheets("Blad1").Range("Table1[#All]").AdvancedFilter xlFilterCopy, Range("Z1:Z2"), Range("A1")
      Range("Z1:Z2").Clear
      Columns.AutoFit
      .SaveAs c00 & ar(j, 1) & Format(Now, "_yyyymmdd-hhmmss"), 51
      .Close 0
    End With
  Next j
End Sub

 

[VenA]

Zelf al wat aanpassingen gedaan/geprobeerd? Macro's worden op maat gemaakt voor een aangeleverd voorbeeldbestand. Als het echte bestand nogal afwijkt van het voorbeeld probeer dan eerst de code zelf aan te passen.

In het nieuwe bestand bestaat 'Blad2' niet en heet nu blijkbaar 'Leveranciers' in dit blad beginnen de gegevens niet in A1. In het blad 'Bestellingen' staat geen tabel. En zo zullen er nog wel meer verschillen zijn. Als je gegevens uit een extern bestand wilt halen kan je daar bv getobject of workbooks.open voor gebruiken. Nu is dit allemaal niet zo heel moeilijk maar als je er zelf niets van begrijpt en niet consistent bent met de voorbeelden dan blijven de helpers aan de gang.