cellen vullen met gegevens uit een ander bestand

[Roncancio]

De nieuwe code voor status:

Sub Klanten()
Dim wBk As Workbook
Dim lRij As Long
    On Error Resume Next
    Set wBk = Workbooks("Klanten")
    If wBk Is Nothing Then
        MsgBox "Het bestand Klanten is niet geopend!", vbExclamation, "Bestand niet geopend."
    Else
    
        lRij = 2
        With wBk.Worksheets(1)
            .Range("F2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value = 0
            While Range("A" & lRij).Value <> ""
            
                With Workbooks("Klanten").Worksheets(1).Range("A:A")
                Set kl = .Find(Range("A" & lRij).Value, , xlValues, xlWhole)
                If Not kl Is Nothing Then
                    kla = kl.Address
                    Do
                        For ikol = 2 To 5
                            If .Cells(kl.Row, ikol).Value = Range("B" & lRij).Value Then
                                If Range("B" & lRij).Value <> "" Then
                                    .Range("F" & kl.Row).Value = IIf(.Range("F" & kl.Row).Value = 0, Range("C" & lRij).Value, "?")
                                End If
                            End If
                        Next
                        Set kl = .FindNext(kl)
                    Loop While Not kl Is Nothing And kla <> kl.Address
                    End If
                End With
                        
                lRij = lRij + 1
            Wend
            
        End With
    End If

End Sub

Met vriendelijke groet,


Roncancio

 

[Warme bakkertje]

Andere aanpak. Plaats de macro in je klantenbestand

Sub tst()
On Error Resume Next
Set wBk = Workbooks("Status.xlsm")
If wBk Is Nothing Then MsgBox "Het bestand Klanten is niet geopend!", vbExclamation, "Bestand niet geopend.": Exit Sub
On Error GoTo 0
With Sheets("Blad1")
    .[J1].CurrentRegion.Clear
    .Range("F2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value = 0
    wBk.Sheets("Blad1").Range("A2").CurrentRegion.Copy .[J1]
    For Each cl In Union(.Range("B2:E" & .Cells(Rows.Count, 1).End(xlUp).Row), .Range("K1:K" & .Cells(Rows.Count, 10).End(xlUp).Row))
        cl.Value = Replace(cl.Value, "*", "#")
    Next
    'sq = .Range("J1:L" & .Cells(Rows.Count, 10).End(xlUp).Row)
    sq = .Range("J1").CurrentRegion
    For Each cl In .[B2:E9]
        If cl <> "" Then
            For i = 1 To UBound(sq)
                If .Cells(cl.Row, 1) = sq(i, 1) And sq(i, 2) = cl Then
                    .Cells(cl.Row, 6) = IIf(.Cells(cl.Row, 6) = 0, sq(i, 3), "?")
                End If
            Next
        End If
    Next
    .[J1].CurrentRegion.Clear
    For Each cl In .Range("B2:E" & .Cells(Rows.Count, 1).End(xlUp).Row)
        cl.Value = Replace(cl.Value, "#", "*")
    Next
End With
End Sub

 

[gershi]

Hallo Rudi

Hartelijk dank voor je macro.

Heb hem uitvoering getest, om een klein bestand van 2000 rijen en 4 kolommen, werkt deze prima, maar in mijn 'eigen' bestand van zo'n 100.000 rijen en 20 kolommen loopt het programma kennerlijk wel door, maar zie ik slechts de eerste 8 rijen gevuld worden, de rest staat allemaal op 0 (nul).
Ook de kolommen na de 'gevulde' kolom zijn allemaal verdwenen.

De code van Roncancio geeft in het kleine bestand exact de zelfde uitkomsten, maar 'werkt' iets langzamer.

In het grote bestand fietst het er in 3:45 minuten doorheen en vooralsnog zonder fouten.

Binnenkort heb ik weer een uitdaging, dan laat ik weer van me horen,

met vriendelijke groet,

Gerard

 

[Warme bakkertje]

Eentje om te testen.
Bereik getest rij 2 tem 100000 en kolom A tem U, resultaat in kolom V

Sub arraytst2()
Dim st(), tempst()
t = Timer
Set wBk = Workbooks("Status.xlsm")
With Sheets("Blad1")
    .Range("V2:V" & .Cells(Rows.Count, 22).End(xlUp).Row).ClearContents
    .[Z1].CurrentRegion.Clear
    wBk.Sheets("Blad1").Range("A2").CurrentRegion.Copy .[Z1]
    sq = .Range("Z1").CurrentRegion
    sn = .Range("A2:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
    x = 1
    For j = 1 To UBound(sn)
        ReDim Preserve st(x)
        st(x) = 0
        For jj = 2 To 21
            If sn(j, jj) <> "" Then
                For i = 2 To UBound(sq)
                    If sq(i, 1) = sn(j, 1) And sq(i, 2) = sn(j, jj) Then
                        st(x) = IIf(st(x) = 0, sq(i, 3), "?")
                    End If
                Next
            End If
        Next
        x = x + 1
    Next
    If UBound(st) > 65536 Then
        ReDim tempst(1 To 65536)
        For i = 1 To 65536
            tempst(i) = st(i)
        Next
    End If
    .Range("V2").Resize(65536) = WorksheetFunction.Transpose(tempst)
    ReDim tempst(1 To UBound(st) - 65536)
        For ii = 1 To UBound(st) - 65536
            tempst(ii) = st(ii + 65536)
        Next
    .Range("V1048576").End(xlUp).Offset(1).Resize(UBound(st) - 65536) = WorksheetFunction.Transpose(tempst)
    .[Z1].CurrentRegion.Clear
End With
MsgBox Timer - t
End Sub

Huidig resultaat .........10 sec. met verbeterde versie