Excelsheets dynamisch combineren

[Warme bakkertje]

@snb

Code is compacter maar de verwerkingstijd benaderd die van @AHulpje dus op dat vlak is er geen verbetering.

 

[JEC.]

met groeperen krijg je er dan inderdaad één regeltje bij

@AHulpje, heb je het pad zo geschreven dat er geen backslash achteraan staat?

let
    Source = Folder.Files("C:\Users\xxx\Downloads"),
    fx = (x)=> Table.SelectRows( Excel.Workbook(x),each [Name] = "Xdwgpos")[Data],
    filter = List.Transform(Table.SelectRows(Source, each Text.StartsWith([Name], "POS"))[Content], fx),
    toTable = Table.Combine(List.Combine(filter)),
    rename = Table.RenameColumns(toTable,{{"Column1", "Aantal"}, {"Column2", "Naam"}, {"Column3", "Omschrijvng"}, {"Column4", "Kleur"}}),
    result = Table.Group(rename, {"Naam", "Omschrijvng", "Kleur"}, {"Aantal", each List.Sum([Aantal]), type nullable number})
in
    result

 

[snb]

@WB
Dan word ik wel nieuwsgierig naar het resultaat van:

Sub M_snb()
    Application.ScreenUpdating = False
    Cells(1).CurrentRegion.ClearContents
    Cells(1).Resize(, 4) = Split("Aantal Naam Omschrijving Kleur")
    c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\~;Extended Properties=""Excel 12.0"""
   
    c01 = Dir(ThisWorkbook.Path & "\POS *.xls")
    Do While c01 <> ""
       With CreateObject("ADODB.recordset")
          .Open "SELECT * FROM `Xdwgpos$`", Replace(c00, "~", c01)
           Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
        End With
        c01 = Dir
    Loop
    Columns.AutoFit
End Sub

 

[AHulpje]

Resultaat in seconden met 40 POS bestanden (10 kopieën van de vier voorbeeldbestanden):
AHulpje 13,8
Warme bakkertje 3,8
snb 3,4
Die van JEC. krijg ik niet aan de praat, maar dat zal aan mij liggen.

 

[JEC.]

apart, waar gaat het mis?

 

[Warme bakkertje]

@snb

Getest op +/- 50 bestanden(copies van POS 02 stofzuiger bestand) en beide codes kwamen qua tijd zo goed als overeen(3.2 tegenover 3.1).

Moest dit echter wel aanpassen omdat niet alle rijen meegenomen werden.

c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\~;Extended Properties='Excel 12.0;HDR=NO'"

 

[AHulpje]

@JEC.
Ik plak jouw query in een nieuw document in een nieuwe lege powerquery, pas de map aan en krijg bij "Alles vernieuwen" onderstaand resultaat. Ik doe vast iets fout.

 

[JEC.]

Data tab —> get data—> zoek naar lege query of blank query —> daarna in de query editor zoeken naar advanced editor. Als je die opent zie je een lege query, daar moet je de code plakken.

Heb je het zo gedaan?

 

[AHulpje]

Nee, ik had hem via de Power query editor geplakt, daar was Geavanceerde editor uitgegrijsd, nu werkt hij wel! En hij is razend snel! Ik weet niet of je er een timer aan zou kunnen toevoegen, maar ik schat ongeveer 2 tellen, dus de snelste van allemaal. Hartelijk dank voor je toelichting.

Het enige foutje dat ik kan ontdekken is een spelfoutje in "Omschrijvng".

 

[JEC.]

Mooizo!

 

[GBO]

Even terug naar deze code:
Sub RunQueryAll()
t = Timer
Dim folderpath As String, filename As String, sn As Variant
Dim sq As Variant, j As Long, jj As Long
Dim cn As Object, rs As Object
Application.ScreenUpdating = False
Cells(1).CurrentRegion.ClearContents '.Delete Shift:=xlUp
Sheets("Totaal").Cells(1).CurrentRegion.ClearContents
folderpath = ThisWorkbook.Path & "\"
filename = Dir(folderpath & "*.xls")
Range("A1").Resize(, 4) = [{"Aantal", "Naam", "Omschrijving", "Kleur"}]
Sheets("Totaal").Range("A1").Resize(, 4) = [{"Aantal", "Naam", "Omschrijving", "Kleur"}]
Do While filename <> ""
If Left(filename, 3) = "POS" Then
flname = folderpath & filename
Set cn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & flname & ";" & _
"Extended Properties='Excel 12.0 Xml; HDR=NO';"
cn.Open
With rs
.ActiveConnection = cn
.CursorType = 3
.Source = "SELECT * FROM [Xdwgpos$]"
.Open
sn = .GetRows: .MoveFirst
End With
rs.Close: Set rs = Nothing

ReDim sq(1 To UBound(sn, 2) + 1, 1 To UBound(sn, 1) + 1)
For j = 0 To UBound(sn)
For jj = 0 To UBound(sn, 2)
sq(jj + 1, j + 1) = sn(j, jj)
Next
Next
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sq), UBound(sq, 2)) = sq
Erase sq
End If
filename = Dir
Loop
cn.Close: Set cn = Nothing
Cells.EntireColumn.AutoFit
Sorteer
Sommeer
Sheets("Totaal").Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.Goto Sheets("Totaal").Range("A1")
MsgBox Timer - t 'MsgBox "Data import complete!"
End Sub

Sub Sorteer()
lRow = Sheets("Import").Range("B" & Rows.Count).End(xlUp).Row
With Sheets("Import").Sort
.SortFields.Clear
.SortFields.Add2 Key:=Range("B1:B" & lRow)
.SortFields.Add2 Key:=Range("C1:C" & lRow)
.SortFields.Add2 Key:=Range("D1" & lRow)
.SetRange Range("A1" & lRow)
.Header = xlYes
.Apply
End With
End Sub

Sub Sommeer()
a = ActiveSheet.UsedRange().Offset(1, 0)
r2 = 1
ReDim sn(1 To UBound(a), 1 To 4)
With Sheets("Totaal")
For r = 1 To UBound(a) - 1
If aantal = 0 Then aantal = a(r, 1)
If a(r, 2) = a(r + 1, 2) And a(r, 3) = a(r + 1, 3) And a(r, 4) = a(r + 1, 4) Then
aantal = aantal + a(r + 1, 1)
Else
sn(r2, 1) = aantal
sn(r2, 2) = a(r, 2)
sn(r2, 3) = a(r, 3)
sn(r2, 4) = a(r, 4)
r2 = r2 + 1
aantal = 0
End If
Next
.Range("A2").Resize(UBound(sn), 4) = sn
End With
End Sub

Kan deze ook de kolommen T t/m Y uit de tabbladen met de naam rekenblad importeren in plaats van de eerste 4 kolommen uit het eerste tabblad en daarna samenvoegen en sommeren?

 

[edmoor]

Plaats code in codetags.
Zo is het niet te volgen.

 

[Warme bakkertje]

En hoe ziet zo'n rekenblad er dan uit ?
Post eens een paar bestanden om een en ander uit te proberen.

 

[GBO]

Bijgaand twee bestandjes. In bestand 1 zit een knop, die alle bestanden in dezelfde map, beginnend met POS, importeert. Hiervoor worden nu de eerste 4 kolommen uit het eerste tabblad gebruikt, maar ik wil eigenlijk de kolommen T t/m Y uit de tabbladen met de naam rekenblad importeren.

 

[AHulpje]

Nog zonder sommeren en sorteren, moet dat wel gebeuren?

 

[GBO]

Nog zonder sommeren en sorteren, moet dat wel gebeuren?

Dat zou wel erg prettig zijn...

 

[AHulpje]

Dan zou het nu erg prettig moeten zijn

 

[GBO]

Fantastisch!! Dank!