Datenzusammenführung, fehlerhaft u langsam

Hallo VBA-Profis,
ich habe eine Arbeitsmappe in der sich auf Tabelle1 alte Daten befinden und auf Tabelle2 aktuelle.
Per Code sollen nun die Daten (Art-Nr1) aus Tabelle1 so auf der Tabelle2 eingefügt werden, dass wenn
1. die Art-Nr1 dort schon vorhanden ist,
1a die entsprechende Info aus Tabelle1 rechts in der selben Zeile angefügt werden
1b bzw wenn die Art-Nr1 öfters genannt ist, Zeilen hinzugefügt werden.
2. die Art-Nr1noch nicht vorhanden ist, Zeilen eingefügt und die Info rechts eingefügt werden
Mein Problem:
Im Testbetrieb (20 - 30 Zeilen) hat alles funktioniert.
Nachdem ich dann aber mit den Originalen (einige 100 Zeilen jeweils) das Macro getestet habe, war nach 20 Minuten das Ergebnis noch nicht fertig und auch nicht alle Daten richtig übertragen.
Mein Lösungsansatz:
Habe versucht mit EndRow die Laufzeit zu beeinflussen. Jedoch werden jetzt nicht mehr alle Daten übertragen (auch im Test).
Ich habe hierzu eine Datei hochgeladen:
https://www.herber.de/bbs/user/81186.xlsm
Sheet1 als "Backup" mit den Testdaten (zum ausprobieren des Makros)
Sheet2 als Tabelle1 als Original der alten Daten
Sheet3 als Tabelle2 als Original der aktuellen Daten in die die alten eingefügt werden sollen
Sheet4 zeigt, was nun das Ergebnis ist
Sheet5 zeigt, was eigentlich raus kommen soll
Meine Frage:
Wer kann mich auf den richtigen Weg bringen und mir sagen,
wo ich den Gedankenfehler habe?
Vielen Dank & viele Grüße
Gert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Gert,
teste mal.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Sub conv_2_lists()
  Dim objShOld As Worksheet, objShNew As Worksheet
  Dim lngRow As Long, lngNext As Long, lngCalc As Long
  Dim vntRet As Variant
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  Set objShOld = Sheets("Tabelle1")
  Set objShNew = Sheets("Tabelle2")
  
  With objShOld
    For lngRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
      vntRet = Application.Match(.Cells(lngRow, 1), objShNew.Columns(1), 0)
      If IsNumeric(vntRet) Then
        If objShNew.Cells(vntRet, 5) = "" Then
          lngNext = vntRet
        Else
          objShNew.Rows(vntRet + 1).Insert
          lngNext = vntRet + 1
        End If
      Else
        lngNext = Application.Max(objShNew.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
      End If
      .Range(.Cells(lngRow, 1), .Cells(lngRow, 3)).Copy objShNew.Cells(lngNext, 5)
      objShNew.Cells(lngNext, 1) = .Cells(lngRow, 1)
    Next
  End With
  
  With objShNew
    .Range("A1:G" & lngNext).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'conv_2_lists'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objShOld = Nothing
  Set objShNew = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Datenzusammenführung, fehlerhaft u langsam

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread