Goedenavond,
Ik loop al enkele dagen te puzzelen met het volgende.
Ik heb in één folder iets meer dan 100 Excel bestanden staan met allemaal eenzelfde opmaak. In kolom A staat een uniek getal. In het ene document kunnen dit er 10 zijn, in het andere document 100.
Wat ik probeer te bereiken is dat Excel automatisch alle bestanden afgaat in de folder en alle informatie uit een basis bestand kopieert. In dit bestand staan in kolom C dezelfde codes als in de Excel bestanden. Alleen is het zo dat in dit bestand de getallen vaker voorkomen, alleen wijkt daar de informatie in kolom D t/m K af.
Ik probeer dus bij de unieke getallen in het ene document. Meerdere resultaten terug te krijgen vanuit het andere document.
Met mijn basis VBA kennis en ChatGPT ben ik een eind gekomen, alleen krijg ik hem niet compleet werkend.
Onderstaande code werkt voor één bestand. Alleen om nu 100+ de worksheet naam aan te passen is wat inefficiënt.
Daarnaast heb ik vanuit chatGPT onderstaande code.
Deze gaat wel automatisch alle bestanden af, alleen blijf ik er tegen aan lopen dat deze slechts de eerste hit kopieert. In plaats van de meerdere waardes die er zijn.
Nu vroeg ik mij af of iemand mij kan verder op weg kan helpen waar ik het moet zoeken. Ik heb diverse dingen proberen samen te voegen echter heb ik het nog niet werkend gekregen.
Ik loop al enkele dagen te puzzelen met het volgende.
Ik heb in één folder iets meer dan 100 Excel bestanden staan met allemaal eenzelfde opmaak. In kolom A staat een uniek getal. In het ene document kunnen dit er 10 zijn, in het andere document 100.
Wat ik probeer te bereiken is dat Excel automatisch alle bestanden afgaat in de folder en alle informatie uit een basis bestand kopieert. In dit bestand staan in kolom C dezelfde codes als in de Excel bestanden. Alleen is het zo dat in dit bestand de getallen vaker voorkomen, alleen wijkt daar de informatie in kolom D t/m K af.
Ik probeer dus bij de unieke getallen in het ene document. Meerdere resultaten terug te krijgen vanuit het andere document.
Met mijn basis VBA kennis en ChatGPT ben ik een eind gekomen, alleen krijg ik hem niet compleet werkend.
Onderstaande code werkt voor één bestand. Alleen om nu 100+ de worksheet naam aan te passen is wat inefficiënt.
code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
| Sub CopyDataFromSchap1()
Dim ws41460 As Worksheet
Dim wsSchap1 As Worksheet
Dim lastRow41460 As Long
Dim lastRowSchap1 As Long
Dim codeColumn As Range
Dim matchRange As Range
Dim codeValue As String
Dim copyRange As Range
Dim destRow As Long
' Set references to worksheets
Set ws41460 = ThisWorkbook.Sheets("Blad1") ' Change to your actual sheet name
Set wsSchap1 = Workbooks("Schap1.xlsx").Sheets("Blad1") ' Change to your actual file and sheet names
' Find the last used rows in both sheets
lastRow41460 = ws41460.Cells(ws41460.Rows.Count, "A").End(xlUp).Row
lastRowSchap1 = wsSchap1.Cells(wsSchap1.Rows.Count, "C").End(xlUp).Row
' Set reference to code column in 41460 sheet
Set codeColumn = ws41460.Range("A1:A" & lastRow41460)
' Initialize destination row
destRow = 2
' Loop through each code in 41460 sheet
For Each matchCell In codeColumn
codeValue = matchCell.Value
' Find matching codes in Schap1 sheet
Set matchRange = wsSchap1.Range("C1:C" & lastRowSchap1).SpecialCells(xlCellTypeConstants, xlTextValues)
' Loop through each match
For Each copyRange In matchRange
If copyRange.Value = codeValue Then
wsSchap1.Range("C" & copyRange.Row & ":K" & copyRange.Row).Copy ws41460.Range("C" & destRow)
destRow = destRow + 1
End If
Next copyRange
Next matchCell
End Sub |
Daarnaast heb ik vanuit chatGPT onderstaande code.
Deze gaat wel automatisch alle bestanden af, alleen blijf ik er tegen aan lopen dat deze slechts de eerste hit kopieert. In plaats van de meerdere waardes die er zijn.
code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
| Sub ExtractDataFromSchap1()
Dim schap1Workbook As Workbook
Dim schap1Worksheet As Worksheet
Dim schap1LastRow As Long
Dim schap1Row As Variant ' Variant to handle potential errors
Dim schap1Number As Long
Dim mainWorkbook As Workbook
Dim fileName As String
' Set the path to the folder containing the Excel files
Dim folderPath As String
folderPath = "C:\Path\To\Your\Folder\"
' Open Schap1 workbook
Set schap1Workbook = Workbooks.Open(folderPath & "Schap1.xlsx") ' Change the file name if needed
Set schap1Worksheet = schap1Workbook.Sheets("Sheet1") ' Change the sheet name if needed
' Get the last row with data in Schap1
schap1LastRow = schap1Worksheet.Cells(schap1Worksheet.Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False ' Turn off screen updating for better performance
' Loop through each Excel file in the folder
fileName = Dir(folderPath & "*.xlsx")
Do While fileName <> ""
If fileName <> "Schap1.xlsx" Then ' Skip Schap1.xlsx
' Open the main workbook
Set mainWorkbook = Workbooks.Open(folderPath & fileName)
Dim mainWorksheet As Worksheet
Set mainWorksheet = mainWorkbook.Sheets(1) ' Change the sheet index if needed
Dim mainLastRow As Long
mainLastRow = mainWorksheet.Cells(mainWorksheet.Rows.Count, "A").End(xlUp).Row
' Loop through each row in the main worksheet
For mainRow = 1 To mainLastRow ' No header, start from row 1
mainNumber = mainWorksheet.Cells(mainRow, "A").Value
' Find mainNumber in Schap1
On Error Resume Next
schap1Row = Application.Match(mainNumber, schap1Worksheet.Columns("C"), 0)
On Error GoTo 0
If Not IsError(schap1Row) Then
' Copy data from Schap1 to the main workbook
schap1Worksheet.Range("C" & schap1Row & ":K" & schap1Row).Copy mainWorksheet.Cells(mainRow, "B")
End If
Next mainRow
mainWorkbook.Close SaveChanges:=True ' Save changes and close main workbook
End If
fileName = Dir ' Move to the next file
Loop
' Close Schap1 workbook without saving changes
schap1Workbook.Close False
Application.ScreenUpdating = True ' Restore screen updating
End Sub |
Nu vroeg ik mij af of iemand mij kan verder op weg kan helpen waar ik het moet zoeken. Ik heb diverse dingen proberen samen te voegen echter heb ik het nog niet werkend gekregen.