Mit Excel VBA Zeilen nach Bestimmten Kriterien einfügen
Hallo zusammen,
bin zur Zeit daran, verschiedene Listen in Excel miteinander abzugleichen.
Dazu habe ich die Listen zunächst aus einer Textdatei eingelesen.
Es handelt sich um eine immer wiederkehrende Abfolge, die jedoch fast nie identisch ist.
Bsp.:
Wert 1
Wert 5
Wert 8
Wert 27
Diese Liste soll mit einer Musterliste abgeglichen werden, die alle denkbaren Werte enthält.
Muster:
Wert 1
Wert 2
Wert 3
Wert 4
usw.
nun habe ich mir überlegt, jede Zelle der Liste zu prüfen und eine Zeile einzufügen, wenn erin Wert fehlt, der in der Musterliste auftaucht.
Hat jemand eine Idee, wie ich das angehen könnte?
Laut Musterliste sind pro Datensatz 60 Zeilen vorgesehen. In der Liste zum Abgleich sind 740 Datensätze enthalten.
Vielleicht kann man ja den Abgleich für einen Datensatz machen und dann einfach nach unten kopieren?
Vielen Dank im Voraus
Viele Grüße
Pascal
bin zur Zeit daran, verschiedene Listen in Excel miteinander abzugleichen.
Dazu habe ich die Listen zunächst aus einer Textdatei eingelesen.
Es handelt sich um eine immer wiederkehrende Abfolge, die jedoch fast nie identisch ist.
Bsp.:
Wert 1
Wert 5
Wert 8
Wert 27
Diese Liste soll mit einer Musterliste abgeglichen werden, die alle denkbaren Werte enthält.
Muster:
Wert 1
Wert 2
Wert 3
Wert 4
usw.
nun habe ich mir überlegt, jede Zelle der Liste zu prüfen und eine Zeile einzufügen, wenn erin Wert fehlt, der in der Musterliste auftaucht.
Hat jemand eine Idee, wie ich das angehen könnte?
Laut Musterliste sind pro Datensatz 60 Zeilen vorgesehen. In der Liste zum Abgleich sind 740 Datensätze enthalten.
Vielleicht kann man ja den Abgleich für einen Datensatz machen und dann einfach nach unten kopieren?
Vielen Dank im Voraus
Viele Grüße
Pascal
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 66059
Url: https://administrator.de/contentid/66059
Ausgedruckt am: 20.11.2024 um 00:11 Uhr
8 Kommentare
Neuester Kommentar
Brauchst du dafür acuh den Quellcode?
Prinzipiell geht es folgendermaßen
deine referenzliste in ein Array
nun ersten wert von arry in variable mit ersten wert liste vergleichen wenn diese sortiert ist. Wenn gleich zweiten wert arry zweiten wert liste. Wenn nicht gleich Zelle einfügen dann WErt aus array einfügen
Wenn du den kompletten Quellcode brauchst kann ich das eben schreiben ansonsten gebe ich dir den Pseudocode der müßte eigentlich reichen
hier mal ein Beispiel
Sub dateilesen()
'Diese Sub kann dazu genutzt werden einen String der eingelesen wird zu ergänzen oder anderweitig zu
'manipulieren. Ebenfalls wird der String bzw alle Streings aus allen vorhandenen Textfiles in eine
'Datei geschrieben
'erstellt am 23.05.2007
'Autor: Sven Günter
'Konstanten die FileSystemObject Objekte besser lesbar zu machen
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Definition der benötigten internen Variablen
Dim abgleich
Dim speicher
Dim fs, a, retstring, b
Dim ML
'Erzeugen des FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")
ML = "24"
'Erzeugen der Zieldatei
'fs.CreateTextFile "c:\gesamtneu.txt"
'Zuweisung der Quelldatei
Set a = fs.opentextfile("C:\xxx\yyyyyy.txt", ForReading, False)
'Zuweisen der Zieldatei
Set b = fs.opentextfile("C:\gesamtneu.txt", ForAppending, True)
'2-24 ohne 12
'Schleife bis das Ende der Quelldatei erreicht ist
Do While a.AtEndOfStream <> True
'Einlesen der 1. zeile
retstring = a.readline
'Erzeugen eines Arrays welches die einzelnen Werte aufnimmt
abgleich = Split(retstring, vbTab, -1)
'MsgBox (retstring)
speicher = 1
'Wenn Bedingung.
If Not retstring = "" And Not speicher = 0 Then
If IsNumeric(abgleich(0)) Then
'Wenn das erste Feld numerisch ist hier die BKN dann wird der komplette satz weggeschrieben
retstring = ML + vbTab + retstring
b.writeline retstring
abgleich = Split(retstring, vbTab, -1)
speicher = abgleich(1)
Do While a.AtEndOfStream <> True And speicher = abgleich(1)
retstring = a.readline
abgleich = Split(retstring, vbTab, -1)
If Not retstring = "" Then
If abgleich(0) = "" Then
'Hier wird der String aufgefüllt mit der BKN die im Merker Speicher steht
retstring = ML + vbTab + speicher + retstring
b.writeline retstring
End If
Else
GoTo naechster
End If
abgleich = Split(retstring, vbTab, -1)
Loop
naechster:
End If
End If
Loop
a.Close
b.Close
End Sub
Dabei wird aber alles aus der Textdatei gelesen und auch wieder in eine textdatei weggeschrieben.
Um Zellen in Excel zu manipulieren machst du folgendes
Sub MuZ()
'Deklaration der Variablen
Dim a As Integer
Dim b As Integer
'Variablen mit Startwert vorbelegen
a = 1
b = 1
'Schleife für das Zeilenweite vorgehen
While Not IsEmpty(Cells(a, b))
If IsNumeric(Cells(a, b)) Then
b = 2
'Schleife für das Reihenweise vorgehen
While Not IsEmpty(Cells(a, b))
'Umformatieren der Zelle
Format (Cells(a, b).NumberFormat = "##,##0.00")
Cells(a, b) = Cells(a, b) * 1
b = b + 1
Wend
End If
b = 1
a = a + 1
Wend
End Sub
in der while schleife kannst du machen was du willst neue zeilen einfügen oder oder oder
Hoffe ich konnte Dir helfen
Gruß
Sven
Das problem bei dir ist das du einen Gruppenwechsel hast wie in meinem ersten Beispiel und du dir die Gruppenmerkamle merken musst und diese abgleichen musst.
Prinzipiell geht es folgendermaßen
deine referenzliste in ein Array
nun ersten wert von arry in variable mit ersten wert liste vergleichen wenn diese sortiert ist. Wenn gleich zweiten wert arry zweiten wert liste. Wenn nicht gleich Zelle einfügen dann WErt aus array einfügen
Wenn du den kompletten Quellcode brauchst kann ich das eben schreiben ansonsten gebe ich dir den Pseudocode der müßte eigentlich reichen
hier mal ein Beispiel
Sub dateilesen()
'Diese Sub kann dazu genutzt werden einen String der eingelesen wird zu ergänzen oder anderweitig zu
'manipulieren. Ebenfalls wird der String bzw alle Streings aus allen vorhandenen Textfiles in eine
'Datei geschrieben
'erstellt am 23.05.2007
'Autor: Sven Günter
'Konstanten die FileSystemObject Objekte besser lesbar zu machen
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Definition der benötigten internen Variablen
Dim abgleich
Dim speicher
Dim fs, a, retstring, b
Dim ML
'Erzeugen des FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")
ML = "24"
'Erzeugen der Zieldatei
'fs.CreateTextFile "c:\gesamtneu.txt"
'Zuweisung der Quelldatei
Set a = fs.opentextfile("C:\xxx\yyyyyy.txt", ForReading, False)
'Zuweisen der Zieldatei
Set b = fs.opentextfile("C:\gesamtneu.txt", ForAppending, True)
'2-24 ohne 12
'Schleife bis das Ende der Quelldatei erreicht ist
Do While a.AtEndOfStream <> True
'Einlesen der 1. zeile
retstring = a.readline
'Erzeugen eines Arrays welches die einzelnen Werte aufnimmt
abgleich = Split(retstring, vbTab, -1)
'MsgBox (retstring)
speicher = 1
'Wenn Bedingung.
If Not retstring = "" And Not speicher = 0 Then
If IsNumeric(abgleich(0)) Then
'Wenn das erste Feld numerisch ist hier die BKN dann wird der komplette satz weggeschrieben
retstring = ML + vbTab + retstring
b.writeline retstring
abgleich = Split(retstring, vbTab, -1)
speicher = abgleich(1)
Do While a.AtEndOfStream <> True And speicher = abgleich(1)
retstring = a.readline
abgleich = Split(retstring, vbTab, -1)
If Not retstring = "" Then
If abgleich(0) = "" Then
'Hier wird der String aufgefüllt mit der BKN die im Merker Speicher steht
retstring = ML + vbTab + speicher + retstring
b.writeline retstring
End If
Else
GoTo naechster
End If
abgleich = Split(retstring, vbTab, -1)
Loop
naechster:
End If
End If
Loop
a.Close
b.Close
End Sub
Dabei wird aber alles aus der Textdatei gelesen und auch wieder in eine textdatei weggeschrieben.
Um Zellen in Excel zu manipulieren machst du folgendes
Sub MuZ()
'Deklaration der Variablen
Dim a As Integer
Dim b As Integer
'Variablen mit Startwert vorbelegen
a = 1
b = 1
'Schleife für das Zeilenweite vorgehen
While Not IsEmpty(Cells(a, b))
If IsNumeric(Cells(a, b)) Then
b = 2
'Schleife für das Reihenweise vorgehen
While Not IsEmpty(Cells(a, b))
'Umformatieren der Zelle
Format (Cells(a, b).NumberFormat = "##,##0.00")
Cells(a, b) = Cells(a, b) * 1
b = b + 1
Wend
End If
b = 1
a = a + 1
Wend
End Sub
in der while schleife kannst du machen was du willst neue zeilen einfügen oder oder oder
Hoffe ich konnte Dir helfen
Gruß
Sven
Das problem bei dir ist das du einen Gruppenwechsel hast wie in meinem ersten Beispiel und du dir die Gruppenmerkamle merken musst und diese abgleichen musst.
Kein Problem. Ich muss gleich in ein Meeting und dann mache ich mich auf den Heimweg. Werde dir nachher von zuhause den kompletten Code posten. Nur nochmal zur Info
Du hast eine Referenztabelle in der alle Werte stehen.
Dann hast du abzugleichende Tabellen in denen nicht alle Werte stehen aber nachher alle werte drinstehen sollen. Sehe das so richtig?
Gruß
Sven
Du hast eine Referenztabelle in der alle Werte stehen.
Dann hast du abzugleichende Tabellen in denen nicht alle Werte stehen aber nachher alle werte drinstehen sollen. Sehe das so richtig?
Gruß
Sven
Hier schonmal vorab der Quellcode.
Option Explicit
'Globale Variablen brauchen wir nachher
Dim zeile As Integer
Dim Spalte As Integer
Private Sub einlesen()
' Hier sind konstanten vorgegeben die brauchen wir fürs FileSystemObject
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Definition der benötigten internen Variablen
Dim abgleich
Dim speicher
Dim fs, a, retstring
zeile = 1
Spalte = 1
'Erzeugen des FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")
Erzeugen des Objectes fürs einlesen der Strings aus dem Textfile
Set a = fs.opentextfile("C:\test\test.txt", ForReading, False)
'Schleife bis das Ende der Quelldatei erreicht ist
Do While a.AtEndOfStream <> True
'Einlesen der 1. zeile
retstring = a.readline
'Erzeugen eines Arrays welches die einzelnen Werte aufnimmt. Hier kann man als Delemiter
' auch tabs oder andere Trennzeichen nehmen. Ich habe in meinem Textfile halt ein Semikolon
'genommen
abgleich = Split(retstring, ";", -1)
'MsgBox (retstring)'Dies ist nur zum Testen gewesen
speicher = 1
'Wenn Bedingung.
'Prüfen ob ein Leerstring übergeben wurde
If Not retstring = "" And Not speicher = 0 Then
'Prüfen ob der erste Teil eine Zahl ist. Hatte das so verstanden das als erstes immer eine
'Zahl ist. Also ein Wert. Wenn dem nicht so ist einfach mit dem abgleichen was da stehen
'sollte
If IsNumeric(abgleich(0)) Then
abgleich = Split(retstring, ";", -1)
speicher = abgleich(1)
'einfuegen in Excel indem die Funktion einfuegen aufgerufen wird. Hier wird der komplette
'String übergeben. Man kann aber auch mehrere Werte übergeben.
einfuegen (retstring)
Else
einfuegen ("Kein Eintrag" + retstring)
End If
End If
Loop
a.Close
End Sub
'Funktion zum einfuegen der einzelnen Werte in Excel.
Private Sub einfuegen(uebergabe)
Cells(zeile, Spalte) = uebergabe
zeile = zeile + 1
End Sub
Das ist das grobe konzept. Wenn du noch Probleme hast kannst du dich auch per mail an mich wenden unter
Sven.Guenter@Sven-Guenter.com
Option Explicit
'Globale Variablen brauchen wir nachher
Dim zeile As Integer
Dim Spalte As Integer
Private Sub einlesen()
' Hier sind konstanten vorgegeben die brauchen wir fürs FileSystemObject
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Definition der benötigten internen Variablen
Dim abgleich
Dim speicher
Dim fs, a, retstring
zeile = 1
Spalte = 1
'Erzeugen des FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")
Erzeugen des Objectes fürs einlesen der Strings aus dem Textfile
Set a = fs.opentextfile("C:\test\test.txt", ForReading, False)
'Schleife bis das Ende der Quelldatei erreicht ist
Do While a.AtEndOfStream <> True
'Einlesen der 1. zeile
retstring = a.readline
'Erzeugen eines Arrays welches die einzelnen Werte aufnimmt. Hier kann man als Delemiter
' auch tabs oder andere Trennzeichen nehmen. Ich habe in meinem Textfile halt ein Semikolon
'genommen
abgleich = Split(retstring, ";", -1)
'MsgBox (retstring)'Dies ist nur zum Testen gewesen
speicher = 1
'Wenn Bedingung.
'Prüfen ob ein Leerstring übergeben wurde
If Not retstring = "" And Not speicher = 0 Then
'Prüfen ob der erste Teil eine Zahl ist. Hatte das so verstanden das als erstes immer eine
'Zahl ist. Also ein Wert. Wenn dem nicht so ist einfach mit dem abgleichen was da stehen
'sollte
If IsNumeric(abgleich(0)) Then
abgleich = Split(retstring, ";", -1)
speicher = abgleich(1)
'einfuegen in Excel indem die Funktion einfuegen aufgerufen wird. Hier wird der komplette
'String übergeben. Man kann aber auch mehrere Werte übergeben.
einfuegen (retstring)
Else
einfuegen ("Kein Eintrag" + retstring)
End If
End If
Loop
a.Close
End Sub
'Funktion zum einfuegen der einzelnen Werte in Excel.
Private Sub einfuegen(uebergabe)
Cells(zeile, Spalte) = uebergabe
zeile = zeile + 1
End Sub
Das ist das grobe konzept. Wenn du noch Probleme hast kannst du dich auch per mail an mich wenden unter
Sven.Guenter@Sven-Guenter.com
Option Explicit
Dim zeile As Long
Dim Spalte As Long
Dim zeileerg As Long
Dim spalteerg As Long
Dim zeileref As Long
Dim i As Integer
Private Sub einlesen()
i = 3
'Definition der benötigten internen Variablen
spalteerg = 1
zeileerg = 1
Dim gesamtzaehler As Long
Dim abgleich As String
Dim kundennummer As String
Dim zeilenmerker As Long
Dim speicher, speicher1, speicher2
Dim fs, a, retstring, b
Dim ML
zeile = 1
zeileref = 1
zeileerg = 1
kundennummer = Tabelle1.Cells(zeile, 1)
'Schleife bis das Ende der Quelldatei erreicht ist
Do While Not Tabelle1.Cells(zeile, 1) = ""
'Einlesen der 1. zeile
SprungmarkeNeueKundennummer:
If CStr(Tabelle1.Cells(zeile, 1)) = CStr(kundennummer) Then
'MsgBox (Tabelle2.Cells(zeile, Spalte))
Do While Not Tabelle2.Cells(zeileref, 1) = ""
If pruefen(Tabelle1.Cells(zeile, 2)) = 1 Then
zeilenanzahlpruefen (zeileerg)
Sheets(i).Cells(zeileerg, 2) = Tabelle1.Cells(zeile, 2)
Sheets(i).Cells(zeileerg, 1) = Tabelle1.Cells(zeile, 1)
zeileerg = zeileerg + 1
zeileref = zeileref + 1
zeile = zeile + 1
If CStr(Tabelle1.Cells(zeile, 1)) = CStr(kundennummer) Then
GoTo sprung2
Else
zeile = zeile - 1
End If
Else
zeilenanzahlpruefen (zeileerg)
Sheets(i).Cells(zeileerg, 2) = Tabelle2.Cells(zeileref, 1) & "Kein Eintrag"
Sheets(i).Cells(zeileerg, 1) = kundennummer & "Kein Eintrag"
zeileref = zeileref + 1
zeileerg = zeileerg + 1
End If
sprung2:
Loop
zeile = zeile + 1
kundennummer = Tabelle1.Cells(zeile, 1)
zeilenanzahlpruefen (zeileerg)
zeileref = 1
Else
zeileref = 1
kundennummer = Tabelle1.Cells(zeile, 1)
GoTo SprungmarkeNeueKundennummer
End If
Loop
End Sub
Private Function zeilenanzahlpruefen(uebergabe As Long)
If zeileerg > 60000 Then
'Hier die Möglichkeit alles Dynamisch zu machen und ein Sheet einzufügen wenn ein neues 'benötigt wird. Habe ihc erstmal weggelassen.
'ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
zeileerg = 1
spalteerg = 1
'i ist die Sheet nummer. Ich weiß ich bin Faul udn es ist nicht sprechend.
i = i + 1
End If
End Function
Private Function pruefen(uebergabe As String) As Integer
If Not CStr(uebergabe) = "" And CStr(uebergabe) = CStr(Tabelle2.Cells(zeileref, 1)) Then
pruefen = 1
Else
pruefen = 0
End If
End Function
Dim zeile As Long
Dim Spalte As Long
Dim zeileerg As Long
Dim spalteerg As Long
Dim zeileref As Long
Dim i As Integer
Private Sub einlesen()
i = 3
'Definition der benötigten internen Variablen
spalteerg = 1
zeileerg = 1
Dim gesamtzaehler As Long
Dim abgleich As String
Dim kundennummer As String
Dim zeilenmerker As Long
Dim speicher, speicher1, speicher2
Dim fs, a, retstring, b
Dim ML
zeile = 1
zeileref = 1
zeileerg = 1
kundennummer = Tabelle1.Cells(zeile, 1)
'Schleife bis das Ende der Quelldatei erreicht ist
Do While Not Tabelle1.Cells(zeile, 1) = ""
'Einlesen der 1. zeile
SprungmarkeNeueKundennummer:
If CStr(Tabelle1.Cells(zeile, 1)) = CStr(kundennummer) Then
'MsgBox (Tabelle2.Cells(zeile, Spalte))
Do While Not Tabelle2.Cells(zeileref, 1) = ""
If pruefen(Tabelle1.Cells(zeile, 2)) = 1 Then
zeilenanzahlpruefen (zeileerg)
Sheets(i).Cells(zeileerg, 2) = Tabelle1.Cells(zeile, 2)
Sheets(i).Cells(zeileerg, 1) = Tabelle1.Cells(zeile, 1)
zeileerg = zeileerg + 1
zeileref = zeileref + 1
zeile = zeile + 1
If CStr(Tabelle1.Cells(zeile, 1)) = CStr(kundennummer) Then
GoTo sprung2
Else
zeile = zeile - 1
End If
Else
zeilenanzahlpruefen (zeileerg)
Sheets(i).Cells(zeileerg, 2) = Tabelle2.Cells(zeileref, 1) & "Kein Eintrag"
Sheets(i).Cells(zeileerg, 1) = kundennummer & "Kein Eintrag"
zeileref = zeileref + 1
zeileerg = zeileerg + 1
End If
sprung2:
Loop
zeile = zeile + 1
kundennummer = Tabelle1.Cells(zeile, 1)
zeilenanzahlpruefen (zeileerg)
zeileref = 1
Else
zeileref = 1
kundennummer = Tabelle1.Cells(zeile, 1)
GoTo SprungmarkeNeueKundennummer
End If
Loop
End Sub
Private Function zeilenanzahlpruefen(uebergabe As Long)
If zeileerg > 60000 Then
'Hier die Möglichkeit alles Dynamisch zu machen und ein Sheet einzufügen wenn ein neues 'benötigt wird. Habe ihc erstmal weggelassen.
'ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
zeileerg = 1
spalteerg = 1
'i ist die Sheet nummer. Ich weiß ich bin Faul udn es ist nicht sprechend.
i = i + 1
End If
End Function
Private Function pruefen(uebergabe As String) As Integer
If Not CStr(uebergabe) = "" And CStr(uebergabe) = CStr(Tabelle2.Cells(zeileref, 1)) Then
pruefen = 1
Else
pruefen = 0
End If
End Function