Option Explicit
[COLOR="red"]Const Bestand2 As String = "C:\Mijn Documenten\Testomgeving\Bestand2.xls" 'voor McMac[/COLOR]ro
'Const Bestand2 As String = "C:\data\Excell\Forum\Bestand2.xls" 'voor Bart
Sub KopierenVan1Naar2()
Dim Recentste As Date, Dossier As String, c1 As Range, c2 As Range, lrij As Long, s As String, i As Integer, Kolommen As Variant, splits As Variant, Waarde As Variant
Dim Sh1 As Worksheet, Sh2 As Worksheet, Bereik As Range, TB1 As Workbook, WB2 As Workbook, bOpen As Boolean
Set TB1 = ThisWorkbook
Set Sh1 = TB1.Sheets("Bestand1") 'doel
[COLOR="red"]Kolommen = TB1.Sheets("blad1").Range("B2:C14") [/COLOR]'lees in een array alle overeenkomstige kolommen in tussen beide bestanden, STAAT IN THISWORKBOOK IN BLAD1 !!!!!!!
If UBound(Kolommen) < 1 Then MsgBox "je hebt niets gevonden over je kolommen": Exit Sub
Recentste = WorksheetFunction.Max(Sh1.UsedRange.Columns(4).Offset(4)) 'recentste datum in bestand1
splits = Split(Bestand2, "\") 'knip verwijzing naar je 2e bestand in stukjes op "\"
On Error Resume Next
Set WB2 = Workbooks(splits(UBound(splits))) 'probeer de map met die filename (zonder path) aan te spreken
bOpen = Not (WB2 Is Nothing) 'onthouden voor straks dat WB2 open staat
If Not bOpen Then
Set Sh2 = Workbooks.Open(Bestand2)
Set WB2 = Workbooks(splits(UBound(splits))) 'probeer de map met die filename (zonder path) aan te spreken
If WB2 Is Nothing Then MsgBox " het bestand " & Bestand2 & " is niet te openen !!!!": Exit Sub
End If
Set Sh2 = WB2.Sheets(1) ' 'bron
MsgBox "kloppen onderstaande gegevens" & vbLf & "Deze map " & vbTab & TB1.Name & vbLf & "2e map " & vbTab & WB2.Name & vbLf & "Recentste datum " & vbTab & Format(Recentste, "dd-mm-yyyy") & vbLf & "aantal rijen in je tabel " & vbTab & UBound(Kolommen) & vbLf & "laatste gegevens in kolommen " & vbTab & Kolommen(UBound(Kolommen), 1) & vbTab & Kolommen(UBound(Kolommen), 2)
With Sh2
.AutoFilterMode = False
.UsedRange.Columns(67).AutoFilter 1, ">=" & CLng(Recentste) 'alle rijen met een datum >= recentste datum
Set Bereik = .UsedRange.Columns(67).SpecialCells(xlVisible) 'alle gefilterde cellen
If WorksheetFunction.CountA(Bereik) = 1 Then MsgBox "geen recente dossiers meer": Exit Sub 'maar 1 rij over = stoppen
For Each c2 In Bereik.SpecialCells(xlConstants) 'alle niet-lege zichtbare cellen aflopen
lrij = c2.Row 'rijnummer in doelbestand
If lrij > 1 Then
Dossier = .Cells(lrij, 6).Value 'dossiernaam
Set c1 = Nothing: Set c1 = Sh1.Columns("C").Find(Dossier, lookat:=xlWhole) 'zoek dossier op in kolom C van doel
If c1 Is Nothing Or c2.Value > Recentste Then 'niet gevonden = toevoegen of datum groter dan recentste = toevoegen
For i = 1 To UBound(Kolommen) 'loop alle te kopieren cellen af
Select Case i 'afhankelijk van te kopieren cel
Case 1: Waarde = IIf(IsEmpty(Sh2.Cells(lrij, Kolommen(i, 2)).Value), "???", Sh2.Cells(lrij, Kolommen(i, 2)).Value) 'dossier mag zeker niet leeg zijn
Case 2: Waarde = CLng(Sh2.Cells(lrij, Kolommen(i, 2)).Value) 'datum wegschrijven als long
Case Else: Waarde = Sh2.Cells(lrij, Kolommen(i, 2)).Value ' al de rest doet er niet toe
End Select
s = s & Waarde & IIf(i = UBound(Kolommen), vbLf, vbTab) 'verzamelstring met gepaste separator
Next
End If
End If
Next
.AutoFilterMode = False
End With
If Not bOpen Then WB2.Close xlNo 'was WB2 niet open, sluit hem hier zonder opslaan
If s = "" Then MsgBox " er werden geen nieuwe dossiers toegevoegd": Exit Sub 'verzamelstring is leeg = stoppen
splits = Split(s, vbLf) 'splits verzamelstring op de vblf
With Sh1 'in doelcel
With Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(splits)) 'kopieer in gebied onder laatste niet-lege C-cel
Application.Goto .Range("A1"), False 'ga op 1e nieuw toegevoegde dossier staan
.Value = WorksheetFunction.Transpose(splits) 'voeg knipsels toe
Application.DisplayAlerts = False
.TextToColumns Tab:=True 'knip knipsels verder in stukken op de vbtab
Application.DisplayAlerts = True
End With
End With
End Sub
,
wat meer toelichting te geven:
