Abgleich von Nummern, Kopieren und einzelne Zellen ersetzen.

Moderator: ModerationP

Abgleich von Nummern, Kopieren und einzelne Zellen ersetzen.

Beitragvon _Marko » 17. Jan 2018, 12:14

Hallo allerseits,

ich habe folgende Problemstellung:
Ich möchte die Nummern aus Tabelle 1 und Tabelle 2 abgleichen. Sofern die gleiche Nummer auftritt, soll in Tabelle 1 die komplette Zeile kopiert und direkt darunter eingefügt werden. Die darunterliegenden Zeilen einfach eine Position weiter nach unten schieben.

Die kopierte Zeile in Tabelle 1 soll nun durch die dreistellige Nummer aus der Tabelle 2 ersetzt werden.
Tabelle 2 dient nur zum Abgleich und Austausch der Nummern. (Wird später von mir in einem anderen Makro gelöscht)

weitere Infos:
die Tabelle1 hat tonnenweise weitere Spalten, die mitkopiert werden müssen.
Tabelle2 hat in Spalte B die zum Abgleichen der Nummer dient. Spalte G entspricht der Nummer, die Tabelle 1 Spalte A ersatzweise eingefügt wird.
Das soll in einer Schleife solange laufen, bis Tabelle 2 komplett abgeglichen/eingefügt ist.


Problem 1
Sofern eine gleiche Nummer gefunden wird, erstellt er mir 7 neue Zeilen mit der selbigen Nummer in Tabelle 1, wobei ich nur eine Kopie brauche, die später durch die 3-stellige Nummer aus Tabelle 2 ersetzt wird.
Problem 2
Das Kopieren mit Worksheets("Tabelle6").Cells(Treffer, 5).Copy Worksheets("Tabelle1").Cells(Zeile + 1, 1) funktioniert nicht.


Den Code habe ich aus verschiedenen Ideen anderer Beiträge zusammengekleistert :'D

Code: Alles auswählen
Sub Step03_Checking_for_Partnumber()

Dim Zeile As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim Nummer As Range

Application.ScreenUpdating = False

  With Tabelle1
    ZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
    For Zeile = 1 To ZeileMax
      Set Nummer = .Range("A" & Zeile)
      If Not Nummer Is Nothing Then
        Set Treffer = Tabelle6.Columns("B").Find(what:=Nummer.Value, lookat:=xlWhole)
        If Not Treffer Is Nothing Then
          Rows(Zeile + 1).Insert (xlShiftDown)
          Rows(Zeile).Copy Rows(Zeile + 1)
          Application.CutCopyMode = False
          Cells(Zeile + 1, 1).ClearContents
          Worksheets("Tabelle6").Cells(Treffer, 5).Copy Worksheets("Tabelle1").Cells(Zeile + 1, 1)
          Application.CutCopyMode = False
          End If
      End If
    Next Zeile
   
End With
 
Application.ScreenUpdating = True

End Sub


Tabelle1-worksheet1
    12345678
    13245679
    13456871
    14455221
    98745612
    uvm.

Tabelle2-worksheet2
    12345700 123
    13245901 124
    13456503 125
    14455221 126
    65478921 127
    uvm.

Für Tipps und Hilfestellungen wäre ich euch sehr dankbar!
Falls weitere Infos benötigt werden, einfach Bescheid geben.

LG
Marko
_Marko
 

Re: Abgleich von Nummern, Kopieren und einzelne Zellen erset

Beitragvon EbyAS » 17. Jan 2018, 16:12

Hallo Marko,
Dein Code kann überhaupt nicht funktionieren! Informatik ist eine Wissenschaft und man kann das sogar studieren.
Sorry nicht böse sein, das sind solche Fehler die man am Anfang macht.
Solche Projekte bei denen man Zeilen einfügen muss (wobei ich das anders sehe) darfst Du niemals von oben nach unten arbeiten lassen (aufsteigend).
Überleg mal: Ganz einfach Du ermittelst ganz oben die Zeilenanzahl die benutzt werden soll, aber wenige Zeilen weiter unten fügst Du eine ein. Aua jetzt stimmt das ja gar nicht mehr und mit jedem Durchlauf wird das schlimmer weil immer wieder eine Zeile dazu kommt. Dämmert schon? Das geht so garnicht oh je, nix ist. Aber jetzt komme ich und sage geht doch nur eben anders.
Du musst nur von unten nach oben laufen lassen(absteigend). Dann drixt man die Anweisung halt aus. Sie merkt es nicht mehr.
Ich habe Dir den Code einmal umgestellt: (mit einigen Kommentaren)

Code: Alles auswählen
Sub Step03_Checking_for_Partnumber()
Dim Zeile As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim Nummer As Range

Application.ScreenUpdating = False
  With Tabelle1
    ZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
    For Zeile = 1 To ZeileMax
      Set Nummer = .Range("A" & Zeile)
      If Not Nummer Is Nothing Then
        Set Treffer = Tabelle6.Columns("B").Find(what:=Nummer.Value, lookat:=xlWhole)
        If Not Treffer Is Nothing Then
          Rows(Zeile + 1).Insert (xlShiftDown)   'ab hier stimmt leider nichts mehr ZeileMax= ist jetzt eine Zeille zu wenig
          'Rows(Zeile).Copy Rows(Zeile + 1)       'einmal abgesehen vom falschen Code; greift die Anweisung auf eine falsche Zeile zu!
          'Application.CutCopyMode = False       ' diese Anweisung ist überflüssig und nicht nötig
          'Cells(Zeile + 1, 1).ClearContents      'Diese Anweisung an dieser Stelle ist überflüssig
          Worksheets("Tabelle6").Cells(Treffer, 5).Copy Destination:=.Cells(Zeile + 1, 1)
          'Application.CutCopyMode = False        ' diese Anweisung ist überflüssig und nicht nötig
          End If
      End If
    Next Zeile   
End With
Application.ScreenUpdating = True
End Sub

Sub Step03_Checking_for_Partnumber_Neu()
Dim Zeile As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim Nummer As Range

Application.ScreenUpdating = False
With Tabelle1
    ZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
    For Zeile = ZeileMax To 1 Step -1
      Set Nummer = .Range("A" & Zeile)
      If Not Nummer Is Nothing Then
        Set Treffer = Tabelle6.Columns("B").Find(what:=Nummer.Value, lookat:=xlWhole)
        If Not Treffer Is Nothing Then
          .Rows(Zeile).Insert (xlShiftDown)
          Worksheets("Tabelle6").Rows(Zeile).Copy Destination:=.Rows(Zeile)
          'Worksheets("Tabelle6").Cells(Treffer, 5).Copy Destination:=.Cells(Zeile, 1) 'Wozu soll das gut sein ? Wurde in der vorhergehenden Zeile schon kopiert
        End If
      End If
    Next Zeile
End With
Application.ScreenUpdating = True
End Sub
:P Ein gern wiederholter Tipp: Das Hochladen einer Beispieldatei, in der zu sehen ist, wie das Ergebnis aussehen soll, ist immer hilfreich und spart Zeit und Rückfragen!

Grüße aus Nürnberg
Armin
Ich benutze WIN 10 (64bit) und Office 13 (64bit)
Benutzeravatar
EbyAS
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 210
Registriert: 06. Aug 2015, 10:25
Wohnort: Nürnberg

Re: Abgleich von Nummern, Kopieren und einzelne Zellen erset

Beitragvon _Marko » 17. Jan 2018, 17:51

Servus Armin,

schon mal Danke für deine Hilfe, ich werde Morgen mich drum bemühen das in Ruhe anzuschauen :D
Ich nehme so was mit Humor, keine Sorge!
Wenn man in den Anfängen ist, dann ist mir jede Hilfe recht.

LG
Marko
_Marko
Neuling
 
Beiträge: 2
Registriert: 17. Jan 2018, 12:15

Re: Abgleich von Nummern, Kopieren und einzelne Zellen erset

Beitragvon _Marko » 23. Jan 2018, 08:48

Guten Morgen Armin,

Danke für deine Hilfe!
Das Makro von dir funktioniert tadellos. Habe es noch ein wenig abgeändert, dass der Ort "destination" passt, aber ich bin nun happy :P


LG
Marko
_Marko
Neuling
 
Beiträge: 2
Registriert: 17. Jan 2018, 12:15


Zurück zu Excel Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: Bing [Bot] und 31 Gäste