• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

macro om data uit andere excelbestanden samen te voegen

Status
Niet open voor verdere reacties.
Ik zal hoe dan ook even plaatsen wat er nu nog ''aan mankeert'', maar het zijn gelukkig allemaal kleine dingen.

In mijn output wordt er steeds eerst de naam van bromap+bestand geplaatst (eerste keer op regel 5)
Vervolgens wordt de titel die in het bronbestand bovenaan staat, geplaatst (op regel 7)
En vervolgens zijn er een aantall lege regels (omdat die er in het bronbestand ook zijn)
...waarna eerst nog een titelbalk wordt ''afgedrukt'' en dan pas de data

Het liefst zou ik alleen de data zien. Dus al het andere mag weg.
De naam van de bronmap en de naam van het bronbestand zou dan steeds op het eind van de regel terecht komen - bij voorkeur.

Enig idee hoe ik dat nog zou kunnen aanpakken?

Ik vraag wel veel nu he :)
 
Misschien om het gemakkelijker te maken: ik zou alleen de dataregells willlen zien die in kolom A van het format "xxxxxC" ofwel van het format "CCxxxxx" zijn, waarbij x een getal van 0 t/m 9 is.
 
Test het zo eens.
Code: 
Sub Consolidation()
Dim j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("ConsolidatieNaam").Range("A11:X1000000").ClearContents
For j = 0 To 2
 Path = Worksheets("Sheet2").Range("B79").Offset(j, 0)
 For Each fl In CreateObject("scripting.filesystemobject").GetFolder(Path).Files
    With Workbooks.Add(fl)
           .Sheets(1).UsedRange.AutoFilter 1, "<>"
           .Sheets(1).AutoFilter.Range.Offset(1).Copy
        ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial -4163
           .Sheets(1).UsedRange.AutoFilter
           .Close False
        ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl
     End With
  Next
 Next j
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub
 
Niet slecht :) het werkt inderdaad, alles komt netjes onder elkaar. Mijn complimenten :) Uiteraard is er wel nog steeds een regel bezet door de titel van de bronfiles (1), door de titelbalk van de bronfiles (2) en door the pad van de bronfile (3), aangezien deze mee worden gekopieerd. Wel zou ik (1) en (2) er nu middels een filter redelijk eenvoudig uit kunnen halen, omdat beide van alle files identiek zijn. (3) zou dus eigenlijk op een andere plaats in mijn excel terecht moeten komen. Is dat nog eenvoudig te regelen, of is dat ingewikkelder dan je zou verwachten?
 
Plaats eens zo'n bronbestand.
 
Is dit beter?
Code: 
Sub Consolidation()
Dim j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("ConsolidatieNaam").Range("A11:X1000000").ClearContents
For j = 0 To 2
 Path = Worksheets("Sheet2").Range("B79").Offset(j, 0)
 For Each fl In CreateObject("scripting.filesystemobject").GetFolder(Path).Files
    With Workbooks.Add(fl)
           .Sheets(1).UsedRange.Offset(9).AutoFilter 1, "<>"
           .Sheets(1).AutoFilter.Range.Offset(1).Copy
        ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial -4163
           .Sheets(1).UsedRange.AutoFilter
           .Close False
        ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl
     End With
  Next
 Next j
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub
 
top!

Werkt uitstekend!! Super bedankt!!

Nu is ie perfect - ik zou alleen nog het pad dat nu steeds onder de data op een aparte regel wordt toegevoegd, aan het einde van iedere regel willen zien.
Dus bijvoorbeeld bestand 1 heeft data op de regels 11 tot en met 20, deze worden nu ingeplakt op regel 11 tot en met 20 en op regel 21 komt dan te staan C:\xxx\yyy.xlsx.
En het zou mooi zijn als ik de yyy op regel 11 tot en met 20 in kolom BX zou zien en de xxx op regel 11 tot en met 20 in kolom BY.
Regel 21 mag dan weg, zodat ik alle data van alle bestanden zonder pad tussendoor in een lange lijst heb staan.
Op zich is het misschien gemakkelijker om dat te doen zodra de lijst volledig is, niet? Dus dat ik de macro houd zoals ie nu is maar een nieuwe macro maak die draait als deze klaar is.

Wel fijn dat ik inmiddels ben waar ik ben - je hebt me uitstekend geholpen :)
 
Test het maar eens weer.
Code: 
Sub Consolidation()
Dim j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("ConsolidatieNaam").Range("A11:X1000000").ClearContents
For j = 0 To 2
 Path = Worksheets("Sheet2").Range("B79").Offset(j, 0)
 For Each fl In CreateObject("scripting.filesystemobject").GetFolder(Path).Files
    With Workbooks.Add(fl)
           .Sheets(1).UsedRange.Offset(9).AutoFilter 1, "<>"
           .Sheets(1).AutoFilter.Range.Offset(1).Copy
        With ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
             rw = .Row
             .PasteSpecial -4163
        End With
           .Sheets(1).UsedRange.AutoFilter
           .Close False
           With ThisWorkbook.Sheets(1)
         If .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row - rw > 0 Then
            .Cells(rw, 76).Resize(.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row - rw) = Split(fl, "\")(UBound(Split(fl, "\")))
            .Cells(rw, 77).Resize(.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row - rw) = Split(fl, "\")(UBound(Split(fl, "\")) - 1)
         End If
        End With
     End With
  Next
 Next j
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub
 
Ik ben onder de indruk - het is perfect! Ongelooflijk! Enorm bedankt voor alle tijd & moeite! Je bent een genie :)
 
Code: 
Sub M_snb()
   Sheets("Cons").usedrange.offset(10).ClearContents
   sn=sheets("sheet2").cells(79,2).resize(3)
    
   for each it in sn
     sp= filter(split(createobject("wscript.shell").exec("cmd /c dir """ & it & "*.*"" /b/s").stdout.readall),vbcrlf),".x")

     For each fl in sp
       ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1,75).resize(,2)=array(dir(fl),it)
       With getobject(fl)
           with .Sheets(1).UsedRange.Offset(9)
              .AutoFilter 1, "<>"
              .Offset(1).Copy ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1)
           end with
           .Close 0
       End With
     Next
   Next
 End Sub
 
Laatst bewerkt:
Graag gedaan,
Mooi om te vernemen dat het allemaal naar wens is.

Ps. Dat laatste is niet helemaal waar. :d
 
Ik heb nog een klein aanvullend vraagje :)

Om de een of andere reden worden op het consolidatieblad alle kolommen (dwz van A t/m XFD) zichtbaar. Dat is op zich niet zo'n drama, ware het niet dat het bestand daardoor onmetelijk groot wordt en ik het niet meer kan oplsaan :( Ik weet niet of het komt doordat een van de bronbestanden deze maximale grootte heeft, maar het lijkt me niet, want alle bestanden hebben een vergelijkbaar aantal bytes. Alss ik slechts een paar bestanden inlees lopen de kolommen gewoon tot BY door, maar als ik alles inlees dus tot XFD (ogenschijnlijk lege kolommen, maar excel vindt het niet zo leuk...). Geen idee waardoor het wordt veroorzaakt.

Kan ik daar iets aan doen? Kan ik bijvoorbeeld in de macro aangeven dat ie alleen kolommen van A t/m BY moet inlezen? Of kan ik mijn consolidatieblad na te hebben ingelezen, weer verkleinen? Kolommen gewoon verwijderen lukt in ieder geval niet, daar loopt ie op vast.
 
Laatst bewerkt:
Code: 
Sub M_snb()
   Sheets("Cons").usedrange.offset(10).ClearContents
   sn=sheets("sheet2").cells(79,2).resize(3)
    
   for each it in sn
     sp= filter(split(createobject("wscript.shell").exec("cmd /c dir """ & it & "*.*"" /b/s").stdout.readall),vbcrlf),".x")

     For each fl in sp
       ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1,78).resize(,2)=array(dir(fl),it)
       With getobject(fl)
           with .Sheets(1).UsedRange.resize(,77).Offset(9)
              .AutoFilter 1, "<>"
              .Offset(1).Copy ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1)
           end with
           .Close 0
       End With
     Next
   Next
 End Sub
 
Thanks! Ik ben even gebruik blijven maken va de macro die ik had maar heb

.Sheets(1).UsedRange.Offset(9).AutoFilter 1, "<>"

aangepast naar jouw versie:

.Sheets(1).UsedRange.Resize(, 77).Offset(9).AutoFilter 1, "<>"

en volgens mij doet ie het nu perfect. Ik kan het bestand ook weer oplsaan - geweldig :)


Allebei hartelijk bedankt!!
 
Maar het kan (veel sneller) helemaal zonder autofilter:

Code: 
Sub M_snb()
   Sheets("cons").usedrange.offset(10).ClearContents
   sn=sheets("sheet2").cells(79,2).resize(3)
    
   for each it in sn
     sp= filter(split(createobject("wscript.shell").exec("cmd /c dir """ & it & "*.*"" /b/s").stdout.readall),vbcrlf),".x")

     For each fl in sp
       ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1,78).resize(,2)=array(dir(fl),it)
       With getobject(fl)
           with .Sheets(1).UsedRange.resize(,77).Offset(9)
              ThisWorkbook.Sheets("cons").Cells(Rows.Count, 1).End(xlUp).Offset(1).resize(.rows.count,77)=.value
           end with
           .Close 0
       End With
     Next
   Next

   ThisWorkbook.Sheets("cons").columns(1).specialcells(4).entirerow.delete
 End Sub
 
:)

Ondertussen heb ik nog een klein verzoekje :) De bronbestanden hebben soms een aantal kolommen gegroepeerd en ingeklapt, waardoor deze data niet in mijn consolidatiesheet getoond wordt en sommige kolommen zelfs op de verkeerde plek terecht komen.
Hoe kan ik de query zo aanpassen dat bij ieder bronbestand eerst overal de groepering uitgeklapt wordt?
 
oh ik heb m al gevonden denk ik :)
Ik heb toegevoegd:

.Sheets(1).Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

En volgens mij werkt ie :)
 
Hmmm...

Er zijn ook slimmerikken die een aantal kolommen verborgen hebben.
Ik dacht die te kunnen tonen door toe te voegen

.Sheets(1).EntireColumn.Hidden = False

maar dat werkt niet echt... Wat doe ik fout? Moet daar nog iets tussen?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan