samenvoegen excel bestanden in bepaalde directory

[enrico85]

Hallo allemaal,

Weet iemand hoe ik meerdere excel bestanden in een bepaalde dir. kan samenvoegen in 1 excel bestand op 1 sheet?
Het aantal regels met gegevens van deze bestanden is variabel. Soms moet ik 20 excel bestanden samenvoegen en soms 150.

Hoor graag of jullie een oplossing weten..

groet
enrico

 

[HSV]

Probeer deze maar eens.

Sub hsv()
Dim Bestandopen As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
 Bestandopen = Dir(ThisWorkbook.Path & "\*")
    Do Until Bestandopen = ""
        If Bestandopen <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & Bestandopen
            Workbooks(Bestandopen).Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
            Workbooks(Bestandopen).Close True
        End If
     Bestandopen = Dir
    Loop
  .DisplayAlerts = True
End With
End Sub

 

[Viewable]

Ik ben hier ook naar op zoek. Via zoek resultaat in dit topic terecht gekomen...

@HSV Ik neem aan dat er nog variabelen ingevuld moeten worden?? Of zet je dit excel bestand bij de te importeren bestanden??

 

[HSV]

Er is maar één variabele, en die is gedeclareerd als string.
Het hoofdbestand moet in deze code in dezelfde map staan als waar de bestanden staan die geïmporteerd moeten worden.

 

[snb]

als het snel moet:

Sub M_snb()
  sn= filter(split(createobject("wscript.shell").exec("cmd /c Dir """ & ThisWorkbook.Path & "\*.xls*"" /b/s").stdout.readall,vbcrlf),":")

  for each it in sn
    with createobject(it).sheets(1).usedrange
       ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).resize(.rows.count,.columns.count)=.value
       .parent.parent.close 0
    end with
  next
End Sub

 

[StijnJR]

Beste iedereen,

Graag zou ik een aanvulling willen vragen.
ik heb het volgende probleem:

Ik lever dagelijks producten uit, daarvan heb ik een deelfactuur.
Die sla ik op in een map met de volgende omschrijving: klantnaam-weeknummer-volgnummer.
Nu zou ik graag willen dat ik die losse excel bestanden per klant en week nummer bij elkaar kan voegen om een totaal factuur te kunnen maken.

Is dat mogelijk ?

Groet,


Stijn

 

[snb]

Alleen als je daarvoor een eigen vraag aanmaakt op dit forum (zie de forumregels).

 

[StijnJR]

Beste Snb,

Mijn excuus, reeds nieuwe vraag gepost.

 

[snb]

Parima !

 

[enrico85]

Ik heb de code van HSV in personal.xlsb gezet. Vervolgens het eerst bestand geopend en de macro uitgevoerd. Echter gebeurd er niks. Alle bestanden staan in dezelfde directory.
Moet ik nog iets aanpassen in de code of werkt het niet op deze manier?

 

[HSV]

Je peronal.xlsb staat in Windows7 hier:

C:\Users\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB

Daar staan vast de andere bestanden niet.

 

[enrico85]

Nee dat klopt inderdaad, die staan ergens anders. Is het ook mogelijk om dan te verwijzen naar een andere directory waar de excel-bestanden staan en dat die dan de bestanden samenvoegt in het geopende excel-bestand?

groet
enrico

 

[HSV]

Verander onderstaande coderegels in waar de bestanden wel staan.

Bv:

 Bestandopen = Dir(ThisWorkbook.Path & "\*")

in.

Bestandopen = Dir("c:\users\enrico\documenten\map1\*")

en deze....

Workbooks.Open ThisWorkbook.Path & "\" & Bestandopen

dan in.

Workbooks.Open "c:\users\enrico\documenten\map1\" & Bestandopen

 

[enrico85]

De macro doet bijna wat ik graag wil

De macro doet alleen de bestanden samenvoegen in personal.xlsb. Kan dit ook samengevoegd worden in het geopende excel-bestand? Zodat ik deze meteen weer kan opslaan.
Verder neemt die de kolombreedte niet over maar dit heeft misschien te maken omdat die het in personal.xlsb zet.
Hij heeft van 1 bestand ook niet alles gekopieerd. checkt die misschien maar tot 110 regels?

groet
enrico

 

[HSV]

Enrico,

Een nieuw bestand wordt automatisch aangemaakt (genaamd "nieuw "+datum en tijd).
De kolommen worden op maximale breedte van de tekstbreedte gezet.
Usedrange gebruikt wat het opheffen van het laatste gevalletje denk ik wel oplost (cellen werden waarschijnlijk overschreven).


Test het zo maar eens.

Sub hsv()
Dim Bestandopen As String, naam As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
   Workbooks.Add
   naam = Format(Now, "dd-mm-yyyy hh_mm_ss")
  activeworkbook.SaveAs "c:\users\enrico\documenten\map1\nieuw " & naam, 51
Bestandopen = Dir("c:\users\enrico\documenten\map1\*")
Do Until Bestandopen = ""
        If Bestandopen <> ThisWorkbook.Name Then
            Workbooks.Open "c:\users\enrico\documenten\map1\" & Bestandopen
            Workbooks(Bestandopen).Sheets(1).UsedRange.Copy Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Cells(Sheets(1).UsedRange.Rows.Count, 1).Offset(1)
            Workbooks(Bestandopen).Close False
        End If
     Bestandopen = Dir
    Loop
      Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit
      Workbooks("nieuw " & naam & ".xlsx").Close , True
 .DisplayAlerts = True
End With
End Sub

 

[enrico85]

Hoi Harry,

Bij de volgende regel loopt die op vast

Workbooks(Bestandopen).Sheets(1).UsedRange.Copy Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Cells(Sheets(1).UsedRange.Rows.Count, 1).Offset(1)

melding is dan:

Fout 9 tijdens uitvoering
Het subscript valt buiten bereik

 

[HSV]

Hoi Enrico,

Je moet het bestanden-pad wel aanpassen waar de pijltjes staan achter de code.
Ik heb een kleinigheidje veranderd.

Sub hsv()
Dim Bestandopen As String, naam As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
   Workbooks.Add
   naam = Format(Now, "dd-mm-yyyy hh_mm_ss")
  activeworkbook.SaveAs "c:\users\enrico\documenten\map1\nieuw " & naam, 51   ' ←
Bestandopen = Dir("c:\users\enrico\documenten\map1\*")  ' ←
Do Until Bestandopen = ""
        If Bestandopen <> ThisWorkbook.Name Then
            Workbooks.Open "c:\users\enrico\documenten\map1\" & Bestandopen    ' ←
            Workbooks(Bestandopen).Sheets(1).UsedRange.Copy Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Cells(Sheets(1).UsedRange.Rows.Count, 1).end(xlup).Offset(1)
            Workbooks(Bestandopen).Close False
        End If
     Bestandopen = Dir
    Loop
      Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit
      Workbooks("nieuw " & naam & ".xlsx").Close  True
 .DisplayAlerts = True
End With
End Sub

 

[enrico85]

Hallo Harry,

Heb even een klein voorbeeld bestand gemaakt waar ik mee werk.

Hij loop nu vast op

Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit

Heb er al Blad1 van gemaakt maar helpt niet.

groeten
enrico

 

[HSV]

Hallo Enrico,

Geen idee, hier werkt het feilloos.
Als je met F8 de code doorloopt, wat is de waarde van 'naam'?

 

[enrico85]

Hallo Harry,

Dat is wel erg vreemd dan.

Wat bedoel je precies met de waarde van 'naam'? het nieuwe bestand dat die aanmaakt?
Als ik de code doorloop met F8 krijg ik vaak de melding 'kan de programmacode niet uitvoeren in de onderbrekingsmodus'.

Enig idee wat het probleem dan kan zijn?

groet
enrico