Dieser Beitrag ist schon älter. Bitte vergewissern Sie sich, dass die Rahmenbedingungen oder der enthaltene Lösungsvorschlag noch dem aktuellen Stand der Technik entspricht.

Mit Excel VBA Zeilen nach Bestimmten Kriterien einfügen

Mitglied: PascalS
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

Content-Key: 66059

Url: https://administrator.de/contentid/66059

Ausgedruckt am: 28.10.2021 um 07:10 Uhr

Mitglied: SvenGuenter
SvenGuenter 13.08.2007 um 14:27:12 Uhr
Goto Top
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.
Mitglied: PascalS
PascalS 13.08.2007 um 15:52:57 Uhr
Goto Top
Hi Sven,

das hilft mir schon weiter. Jedenfalls weiss ich jetzt, dass es eine Lösung gibt :-) face-smile

Allerdings bin ich in VBA noch nicht so fit.
Könntest Du mit bei dem Code vielleicht etwas auf die Sprümnge helfen?

Wäre echt super.

Viele Grüße

Pascal
Mitglied: SvenGuenter
SvenGuenter 13.08.2007 um 15:56:02 Uhr
Goto Top
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
Mitglied: PascalS
PascalS 13.08.2007 um 16:05:17 Uhr
Goto Top
Hio Sven, das ist ja echt supernett.

Ja richtig, es liegt eine Referenztabelle mit ca 60 Zeilen vor.
Die abzugleichenden Tabellen sind nicht vollständig. Es fehlen auch immer andere Positionen.


Dabei ist es nicht zwingend erforderlich, dass Werte darin stehen. Es wäre nur gut, wenn später die fehlenden Positionen zumindest durch Leerzeilen aufgefüllt wären.

Später sollen die Werte, die sich darin befinden dann gegengerechnet werden um die Richtigkeit zu prüfen.

Als Vorabinformation:

1.Es handelt sich um eine importierte Textdatei.

2.Zum diesem Zeitpunkt ist noch keine Spaltentrennung erfolgt --> also eigentlich nur eine
Spalte relevant.

3. Problematisch könnte sein, dass auf der rechten Seite, der Zellen immer individuelle
Zahlenwerte stehen. Vielleicht ist es daher möglich nur die übereinstiummenden Texte zu
prüfen und ggf eine Leerzeile einzufügen

Viele Grüße

Pascal
Mitglied: SvenGuenter
SvenGuenter 14.08.2007 um 07:52:06 Uhr
Goto Top
hi Pascal sicher ist es das. Das macht man mit einer Prüfroutine. Gib mir doch bitte noch einen Datensatz wie der in der Textdatei aussieht.
Ein Datensatz bei mir in der Datei sieht wie folgt aus

1;Textbeispiel;123,45€
2;Textbeispiel;234,56€
Mitglied: SvenGuenter
SvenGuenter 14.08.2007 um 08:29:08 Uhr
Goto Top
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
Mitglied: SvenGuenter
SvenGuenter 20.08.2007 um 09:38:51 Uhr
Goto Top
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
Mitglied: PascalS
PascalS 20.08.2007 um 09:40:58 Uhr
Goto Top
Hallo Sven,

vielen Dank, das war die richtige Lösung! :-) face-smile

Viele Grüße
Pascal
Heiß diskutierte Beiträge
question
Netzwerktool mit IP-SettingsServer2503Vor 1 TagFrageNetzwerkmanagement4 Kommentare

Hallo zusammen, ich meine aus meiner Schulzeit zu wissen, dass es ein Tool gibt, mit dem ich ein Netzwerkplan (Clients, Switches, Router etc.) samt IP-Einstellungen ...

question
Exchange 2016 CU22 blockt sporadisch eingehende Mails gelöst anteNopeVor 1 TagFrageExchange Server5 Kommentare

Hallo zusammen, wir haben hier ein echt lästiges Thema bei dem wir nicht weiter wissen. Und zwar blockt der Exchange bei einem Kunden "sporadisch" Mails. ...

question
Benutzername auf HTTPS Webseite für NAS SyncBischi007Vor 1 TagFrageWebbrowser4 Kommentare

Hallo zusammen, folgendes Problem, bzw. Frage: Für den Download von Dateien wird von einem Softwarehersteller eine Webseite angeboten, Aufruf erfolgt via https es folgt dann ...

question
Zertifikate für Multifunktionsgeräte gelöst Net-ZwerKVor 1 TagFrageDrucker und Scanner4 Kommentare

Moin! Ich habe einen Kunden, der von seinem Rechenzentrum vorgeschrieben bekommt, dass seine Multifunktionsgeräte nun die Adressbuchabfrage per LDAPs machen müssen. Das Rechenzentrum hat auch ...

info
VCenter 7.0 U3a verfügbarLooser27Vor 1 TagInformationVmware3 Kommentare

Guten Morgen, das neue vCenter 7.0 U3a steht zum Download bereit. Patchnotes: Gruß Looser ...

question
Verwirrung VLSC Anmeldung gelöst dertowaVor 1 TagFrageMicrosoft4 Kommentare

Hallo zusammen, Microsoft kann einen ja schon mal in verwirren und soweit ist es heute wieder. Ich melde mich wie gehabt an unserem VLSC Konto ...

info
Veeam B and R 11.0.1.1261 verfügbarLooser27Vor 1 TagInformationBackup2 Kommentare

Guten Morgen, die neue Version von Veeam 11 (passend zum VMWare Update) steht zum Download bereit. Gruß Looser ...

question
Browser mit fest konfigurierter Adresse und OptionenyaschixVor 1 TagFrageWebbrowser6 Kommentare

Hi all, meine erster Beitrag - Danke dass ich dabei sein kann! Zu meinem Problem - Wir haben einen Kunden im Bereich der Produktion, der ...