Namen in meerdere sheets vergelijken, en waarden optellen

[marc651]

Ja, doet het.

En mijn andere vraag?
Hoe voeg ik meerdere documenten toe in de functie, bv Ivk3, Ivk4, enz

 

[HSV]

Breid de 'Case' en de daarbij horende 'For y = 0 to 2' uit voor meerdere.

Private Sub CommandButton1_Click()
Dim ThWb As Object, cl As Range, c As Range, y As Long, firstaddress As String, n as long
Application.ScreenUpdating = False
Set ThWb = ThisWorkbook.Sheets("Januari")
ThWb.Range("A4:I" & IIf(ThWb.Cells(4, 1) = vbNullString, 4, ThWb.Cells(Rows.Count, 1).End(xlUp).Row)).ClearContents
 Workbooks.Open "F:\Mijn Documenten\Rooster\zes.xlsx"
   With ActiveWorkbook
For Each cl In .Sheets("ORT Januari").Range("A5:A15").SpecialCells(2)
    ThWb.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
Next cl
ActiveWorkbook.Close False
End With
For y = 0 To 2
     Select Case y
   Case 0
     Workbooks.Open "F:\Mijn Documenten\Rooster\zeven.xlsx"
   Case 1
     Workbooks.Open "F:\Mijn Documenten\Rooster\acht.xlsx"
   Case 2
     Workbooks.Open "F:\Mijn Documenten\Rooster\negen.xlsx"
 End Select
With ActiveWorkbook
    For Each cl In .Sheets("ORT Januari").Range("A5:A15").SpecialCells(2)
 Set c = ThWb.Columns(1).Find(cl, , xlValues, xlWhole)
 If Not c Is Nothing Then
    firstaddress = c.Address
 Do
   If Join(Application.Index(cl.Resize(, 3).Value, 1, 0)) = _
   Join(Application.Index(c.Resize(, 3).Value, 1, 0)) Then
         c.Offset(, 3) = c.Offset(, 3) + cl.Offset(, 3)
         c.Offset(, 4) = c.Offset(, 4) + cl.Offset(, 4)
         c.Offset(, 5) = c.Offset(, 5) + cl.Offset(, 5)
         c.Offset(, 6) = c.Offset(, 6) + cl.Offset(, 6)
         n = n + 1
     End If
  Set c = ThWb.Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
   If n = 0 Then ThWb.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
   Else
     ThWb.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
       End If
    Next cl
   ActiveWorkbook.Close False
 End With
 Next y
End Sub

 

[marc651]

Dit is het.
Bedankt Harry

 

[marc651]

Bekijk bijlage Ivk5.xlsm
Excuses, maar ik ben er weer.
Ik vind het erg vervelend, maar ik blijf problemen krijgen.
Als ik het bestand Ivk laat zoeken in een bestand met verwijzingen en wat VBA, dan zegt hij dat hij geen cellen kan vinden.
In dit geval gaat het om bestand Ivk5 (xlsm bestand).
De layout is exact hetzelfde. De naam van de sheet klopt. De getallen die hij moet ophalen zijn opgeteld uit cellen in het sheet ervoor(Januari).

Groet Marc

 

[HSV]

Verwijder ".SpecialCells(2)" eens.

 

[marc651]

Als ik dat doe dan krijg ik een zandloper.
Als ik deze geforceerd wegklik, dan staat alles vol met nullen.

 

[marc651]

Als ik alleen de bovenste(.SpecialsCells2) weg haal, dan krijg ik 3 namen met hun waarden,
dan een hoop nullen, en dan de volgende namen.

 

[HSV]

En zo?

Workbooks.Open "F:\Mijn Documenten\Rooster\zes.xlsx"
   With ActiveWorkbook
For Each cl In .Sheets("ORT Januari").Range("A5:A15")
[COLOR=#FF0000] if cl > 0 then[/COLOR]
    ThWb.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
[COLOR=#FF0000] end if[/COLOR]
    Next cl
  ActiveWorkbook.Close False
End With

 

[marc651]

Als ik hem laat lezen uit 4 documenten slaat hij Case 0 en Case 2 over.

 

[HSV]

Lijkt me onmogelijk,
De variabel "Y" heeft altijd een waarde en begint met 0 en loopt door de "For, Next" lus ze allemaal bijlangs.

 

[marc651]

Harry,

Hij werkt. Eén van de documenten stond in een andere map. Ik weet niet waarom, maar nadat ik de volgorde van documenten in de code verandert had werkte het
Ben tevreden zo.
Bedankt.