Opgelost Gegevens van meerdere Excel bestanden samenvoegen naar 1 tabblad

[Georgyboy]

Dank voor de vele leerrijke reacties voor mij een geschenk!
Bekijk dit morgen allemaal verder

 

[JEC.]

@Cow, dan hier ook nog een variant

Sub jec()
  Dim xp, xs, xDriver, sqlString
  Dim a, sh, rs As Object
 
  xp = "C:\Users\xxxx\Downloads\test\"
  xs = Dir(xp & "Programma*.xlsx")
 
  Set sh = ThisWorkbook.Sheets(1)
  Set rs = CreateObject("ADODB.recordset")
 
  sh.Cells(1).CurrentRegion.Resize(, 14).ClearContents
  sh.Cells(1).Resize(, 14) = Array("Programma", "Batch", "Date", "Time", "Step", "Baseprogram ID", "Baseprogram", "", "chamberTemp", "coreTemp", "", "chamberTemp", "coreTemp", "FValue")
  Do While xs <> ""
     xDriver = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xp & xs & ";Extended Properties=""Excel 12.0;HDR=No;"""
     sqlString = "SELECT * FROM `Recipe$A3:L`"
     rs.Open sqlString, xDriver
     a = rs.getrows
     With sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
          .Resize(UBound(a, 2) - 8, 2) = Array(a(0, 0), a(1, 3))
           rs.Close
           rs.Open Replace(sqlString, "Recipe$A3:L", "Recipe$A12:L"), xDriver
          .Offset(, 2).CopyFromRecordset rs.DataSource
     End With
     xs = Dir
     rs.Close
  Loop
End Sub

 

[cow18]

@JEC. ach zo, jij begint altijd vanaf een leeg blad en ik keek of iets al niet behandeld had. 2 zienswijzen, die netjes naast elkaar kunnen staan.
Voor de rest, ik zal me er eens moeten in verdiepen, want die techniek heb ik niet onder de knie.

 

[JEC.]

Een snellere manier om data vanuit andere bestanden binnen te halen via VBA, heb ik nog niet gevonden. Toch zou ik voor Power Query kiezen

 

[cow18]

je hebt gelijk, maar ik heb koudwatervrees. (is eigenlijk geen argument)

 

[Georgyboy]

Bedankt voor de vele leerrijke info!
Sorry voor mijn late reactie

De Code van JEC gaat als een flits alsook de code in Power Query

De powerquery met de aanpassing opmerking van Peter59, echt knap! even vernieuwen voor de nieuwe bestanden te herladen.

let
Source = Folder.Files("C:\Users\Georges\Documents\Documenten\GEORGES\Forum Helpmij - Worksheet\Samenvoegen naar 1 Map"),
fltr_files = Table.SelectRows(Source, each Text.Contains([Name], "Programma")),
fltr_hidden_files = Table.SelectRows(fltr_files, each [Attributes]?[Hidden]? <> true),
get_content = Table.Combine(List.Transform(fltr_hidden_files[Content], each Excel.Workbook(_))),
expand = Table.ExpandTableColumn(get_content, "Data", Table.ColumnNames(get_content[Data]{0})),
delCols = Table.RemoveColumns(expand,{"Column6", "Column9", "Item", "Kind", "Hidden"}),
Headers = Table.RenameColumns(delCols,{{"Column1", "Date"}, {"Column2", "Time"}, {"Column3", "Step"}, {"Column4", "BadeprogramID"}, {"Column5", "Baseprogram"}, {"Column7", "ChamberTemp"}, {"Column8", "coreTemp"}, {"Column10", "chamberTempp"}, {"Column11", "coreTempp"}, {"Column12", "FValue"}}),
GetBatch = Table.AddColumn(Headers, "Batch", each if [Date] = "Batch:" then [Time] else null),
GetProg = Table.AddColumn(GetBatch, "Programma", each try if Text.Contains([Date], "Programma") or Text.Contains([Date], "PROCES") then [Date] else null otherwise null),
fill = Table.FillDown(GetProg,{"Batch", "Programma"}),
keep_dates = Table.SelectRows(fill, each Value.Type([Date]) = type datetime),
reorder = Table.ReorderColumns(keep_dates,{"Programma", "Name", "Batch", "Date", "Time", "Step", "BadeprogramID", "Baseprogram", "ChamberTemp", "coreTemp", "chamberTempp", "coreTempp", "FValue"}),
result = Table.TransformColumnTypes(reorder,{{"Date", type date}, {"Time", type time}})
in
result

De code van Cow18 loopt bij mij vast om een of andere reden, zal aan mij liggen. interessante info

Jammer lukt de code van snb niet bij mij, zal ook aan mij liggen zeker? lijkt ook interessant zo beknopte code.

Zo blij met al deze reacties en info

Groeten,
Georgyboy

 

[snb]

Ik vermoed dat als je de programmabestanden in C:\Users\ zet de code vlekkelings loopt.

 

[cow18]

of gewoon alle bestanden in dezelfde subdirectory van dat samenvoeg-bestand en dan

Sub M_snb()
     c00 = ThisWorkbook.Path & "\"           'je subdirectory van je bestanden
     c01 = Dir(c00 & "Programma *.xlsx")     'zo noemen je bestandjes en ook per direct het eerste bestand die zo noemt
     Set sh = ThisWorkbook.Sheets("Blad1")   'blad in deze file waar je naar toe kopieert

ik had nog een extra spatie tussen die "Programma *.xlsx" staan, anders ook eens zonder die spatie

jij hebt daar nu een gedrocht staan als path
c00 = ThisWorkbook.Path & "\" & "C:\Users\......"
als je die "C:\users\..." gebruikt moet die thisworkbook.path &"\" uiteraard weg.

 

[Georgyboy]

@ snb

Mijn excuses voor je moeite!
Heb de bestanden in een map op de c\schijf (korte link)

Heb een fout tijdens het lopen van de code fout 424

@ Cow18
Denk als ik dit van snb goed krijg zal het denk ik ook lukken,
heb de spatie weg gelaten.

Zal hier weer veel van leren wat ik met deze geschenken fout doe!

 

[snb]

Je gebruikt niet het bestand dat ik plaatste.
Kontroleer de namen van de werkbladen.
Jouw bestand bevat blijkbaar geen werkblad met de codename 'sheet2'.
Pas dit aan.

 

[Georgyboy]

Gelukt

Dankjewel snb,
gewijzigd "sheet2" naar "blad1"

Werkt in een flits!

P.s. stel we dit doen op 100 bestanden of méér in één keer, zou dit dan ook nog lukken?

Sub M_snb()
c00 = "C:\snb\Snb\"
c01 = Dir(c00 & "Programma*.xlsx")
Do While c01 <> ""
With GetObject(c00 & c01)
.Sheets(1).UsedRange.Offset(11).Copy Blad1.Cells(Rows.Count, 2).End(xlUp).Offset(1)
Blad1.Columns(2).SpecialCells(2).Offset(, -1).SpecialCells(4) = c01
.Close 0
End With
c01 = Dir
Loop
End Sub

 

[snb]

Ik kan niet zien hoeveel gegevens jouw bestanden bevatten. Jouw werkblad kan max. 1.048.576 rijen bevatten
Dus gemiddeld per bestand 10.485 regels
Ik kan evenmin zien hoeveel kolommen ieder bestand heeft. Als ze niet meer dan 160 kolommen bevatten kun je ook minstens 100 bestanden naast elkaar zetten. Dan heb je het al over de gegevens van 10.000 bestanden in 1 werkblad.
De macro hoef je niet te veranderen, tenzij je gegevens ook naast elkaar wil zetten.

 

[Georgyboy]

Dank voor de info,

Het aantal kolommen is altijd 12, waarvan kolom 6 en 9 leeg zijn (mogen eigenlijk worden gewist)
voor rij 1 mogen de kolomtitels


Kan dit nog tussen jouw werkende code?

Alvast bedankt!

@cow18
Probeer jouw code ook nog eens aan te passen bij wijze van bijleren met al deze nuttige antwoorden en info

 

[Georgyboy]

Ook gelukt

Sub M_snb()
c00 = "C:\snb\snb\" 'je subdirectory van je bestanden
c01 = Dir(c00 & "Programma*.xlsx") 'zo noemen je bestandjes en ook per direct het eerste bestand die zo noemt
Set sh = ThisWorkbook.Sheets("Blad1") 'blad in deze file waar je naar toe kopieert
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare

Set c = sh.Cells(Rows.Count, 1).End(xlUp) 'laatst gebruikte cel
If c.Row > 1 Then
aa = sh.Range("A1").Resize(c.Row, 2).Value 'inlezen 1e 2 kolommen
For i = 2 To UBound(aa)
dict(aa(i, 1) & "|" & aa(i, 2)) = vbEmpty 'unieke combinaties opslaan
Next
End If

Application.ScreenUpdating = False
Do While c01 <> "" 'loopje door alle gelijkaardige bestanden
With GetObject(c00 & c01).Sheets(1) 'open bestandje op de achtergrond en gebruik 1e blad
Application.StatusBar = c00 & c01: DoEvents
arr = Array(.Range("B6").Value, .Range("A3").Value) 'ophalen van deze 2 vaste gegevens
s = Join(arr, "|") 'die combinatie
If Not dict.exists(s) Then 'bestaat die nog niet ?
dict(s) = vbEmpty 'dan die ook toevoegen aan dictionary
Set c = .Range("A12").CurrentRegion.Resize(, 12) 'je procesgegevens vanaf A12, 12 kolommen breed
With sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(c.Rows.Count) 'doelcel
.Resize(, 2).Value = arr 'je 2 vaste gegevens
.Offset(, 2).Resize(, c.Columns.Count).Value2 = c.Value2 'de procesgegevens
End With
End If
.Parent.Close 0 'bestand sluiten zonder opslaan
End With
c01 = Dir 'volgende gelijkaardige bestand
Loop

With sh
.Range("C:C").NumberFormat = "dd-mm-yy" 'datum
.Range("D").NumberFormat = "hh:mm:ss" 'tijd (zijn eigenlijk 2 keer dezelfde waarden
.Range("L:N").NumberFormat = "0.0" 'temperaturen tot op een tiende graad
.Range("A1").Resize(, 12).EntireColumn.AutoFit
End With

Application.StatusBar = False
Application.CutCopyMode = False
Application.Goto ActiveCell
Application.ScreenUpdating = True

End Sub

 

[snb]

Sub M_snb()
  Blad1.Cells(1).resize(,12)=array("Date","Time","Step","Baseprogram_ID","Baseprogram","","chamberTemp","coreTemp","","chamberTemp","coreTemp","FValue")

  c00 = "C:\snb\Snb\"
  c01 = Dir(c00 & "Programma*.xlsx")
   Do While c01 <> ""
      With GetObject(c00 & c01)
         .Sheets(1).UsedRange.Offset(11).Copy Blad1.Cells(Rows.Count, 2).End(xlUp).Offset(1)
         Blad1.Columns(2).SpecialCells(2).Offset(, -1).SpecialCells(4) = c01
         .Close 0
      End With
      c01 = Dir
  Loop
  Blad1.columns(9).delete
  Blad1.columns(6).delete
End Sub

 

[Georgyboy]

Wederom bedankt !

Zo leerrijke info

Kan er nog een stukje bij? zijnde de belangrijke Batch uit cel B:6 Die bij de aangepaste code van Cow18 in kolom A staat.
Vraag wellicht véél?

Wil ieder hartelijk danken voor alle verkregen info en oplossingen zowel met VBA als met Power Query.

Sub M_snb_Cow18()
c00 = "C:\snb\snb\" 'je subdirectory van je bestanden
c01 = Dir(c00 & "Programma*.xlsx") 'zo noemen je bestandjes en ook per direct het eerste bestand die zo noemt
Set sh = ThisWorkbook.Sheets("Blad1") 'blad in deze file waar je naar toe kopieert
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare

Set c = sh.Cells(Rows.Count, 1).End(xlUp) 'laatst gebruikte cel
If c.Row > 1 Then
aa = sh.Range("A1").Resize(c.Row, 2).Value 'inlezen 1e 2 kolommen
For i = 2 To UBound(aa)
dict(aa(i, 1) & "|" & aa(i, 2)) = vbEmpty 'unieke combinaties opslaan
Next
End If

Application.ScreenUpdating = False
Do While c01 <> "" 'loopje door alle gelijkaardige bestanden
With GetObject(c00 & c01).Sheets(1) 'open bestandje op de achtergrond en gebruik 1e blad
Application.StatusBar = c00 & c01: DoEvents
arr = Array(.Range("B6").Value, .Range("A3").Value) 'ophalen van deze 2 vaste gegevens
s = Join(arr, "|") 'die combinatie
If Not dict.exists(s) Then 'bestaat die nog niet ?
dict(s) = vbEmpty 'dan die ook toevoegen aan dictionary
Set c = .Range("A12").CurrentRegion.Resize(, 12) 'je procesgegevens vanaf A12, 12 kolommen breed
With sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(c.Rows.Count) 'doelcel
.Resize(, 2).Value = arr 'je 2 vaste gegevens
.Offset(, 2).Resize(, c.Columns.Count).Value2 = c.Value2 'de procesgegevens
End With
End If
.Parent.Close 0 'bestand sluiten zonder opslaan
End With
c01 = Dir 'volgende gelijkaardige bestand
Loop

With sh
.Range("C:C").NumberFormat = "dd-mm-yy" 'datum
.Range("D").NumberFormat = "hh:mm:ss" 'tijd (zijn eigenlijk 2 keer dezelfde waarden
.Range("L:N").NumberFormat = "0.0" 'temperaturen tot op een tiende graad
.Range("A1").Resize(, 12).EntireColumn.AutoFit
End With

Application.StatusBar = False
Application.CutCopyMode = False
Application.Goto ActiveCell
Application.ScreenUpdating = True

End Sub

 

[Georgyboy]

Goede avond,
Heel blij met de vele werkende codes, echt super werkend

Mag ik nog 1 vraag stellen?

1° vraag:
Kunnen we gegevens van de 3 Excelbestanden Batchnummer B6 en Proces uit Rij 3 (samengevoegde cel) in een lijst krijgen in bestand "Samenvoegen"?

Bedoel beknopt:

Batch:	Proces	Start:	End:
26743241​	PROCES 3	26/10/2023 11:19​	26/10/2023 13:59​

Alvast bedankt

 

[cow18]

er zijn een paar dingetjes aangepast
Het gekke/grappige is dat voor je 3 bestanden, tussen een leeg "samenvoeg"-bestand en een bestand waar je 3 voorbeeld-bestanden al in zijn samengevoegd, het lege "samenvoeg"-bestand toch nog net iets sneller is. Dus is eigenlijk het openen/sluiten op de achtergrond van die bestanden de bepalende factor.

 

[Georgyboy]

wauw knap! Hartlijk dank

Mag ik nog een vraag?
Kunnen we ook een lijst maken met de beknopte gegevens?
Dus enkel 4 kolommen, titels en 3 lijnen omdat er in dit geval 3 batchen zijn. Zie #37

Waarom die vraag, omdat we aan de hand van het batchnummer kunnen zien welk product daar aan gekoppeld is.
De batchnummers en producten kunnen we halen uit een andere lijst via query s.

Alvast bedankt!

Groeten,
Georgyboy

 

[Georgyboy]

Aanvulling op vorige vraag #39

Om mijn vraag compleet af te sluiten met de zovele mogelijkheden
Wellicht kan dit ook met een aanpassing op de Query van JEC?

Hopelijk hebben velen er ook blij met deze topic en de vele interessante antwoorden?

Alvast bedankt!