VBA "sverweis" aber ohne 0 Ergebnisse

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Dim wkb As Workbook Dim wksQ As Worksheet Dim wksZ As Worksheet Sub DatenSammeln() Dim i As Long Dim j As Integer Dim lletzteZeileQ As Long Dim lletzteZeileZ As Long Dim lletzteSpalteQ As Long Dim lletzteSpalteZ As Long Dim strRange As String Dim rng As Range Dim bEingetragen As Boolean Dim lreihe As Long Dim lReiheErste As Long Initialisiere lletzteZeileQ = wksQ.Cells(Rows.Count, 2).End(xlUp).Row lletzteZeileZ = wksZ.Cells(Rows.Count, 2).End(xlUp).Row lletzteSpalteQ = wksQ.Cells(7, 256).End(xlToLeft).Column lletzteSpalteZ = wksZ.Cells(7, 256).End(xlToLeft).Column strRange = "B7:B" & lletzteZeileZ For i = 8 To lletzteZeileQ Set rng = wksZ.Range(strRange).Find(wksQ.Cells(i, 2).Value) If Not rng Is Nothing Then lreihe = rng.Row lReiheErste = lreihe For j = 8 To lletzteSpalteQ If wksQ.Cells(i, j).Value "" Then lreihe = lReiheErste bEingetragen = False Do While bEingetragen = False If wksZ.Cells(lreihe, j).Value = "" Then bEingetragen = True wksZ.Cells(lreihe, j).Value = wksQ.Cells(i, j).Value Else lreihe = lreihe + 1 If wksZ.Cells(lreihe, 2).Value wksQ.Cells(i, 2).Value Then MsgBox ("Nicht genug Zeilen in Zielsheet für " & wksQ.Cells(i, 2) _ .Value & " vorhanden") Exit Sub End If End If Loop End If Next j End If Next i End Sub Function Initialisiere() Set wkb = ThisWorkbook Set wksQ = wkb.Sheets("Details_MA") Set wksZ = wkb.Sheets("Details_MA2 (2)") 'hier anpassen End Function

Hallo Jasmin,
ja auch das ist möglich :-)
wksZ.Rows(lreihe & ":" & lreihe).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
anstatt der MsgBox und exit sub
Erklärung versuch ich mal:
In Initialisiere schaffe ich mir Variablen mit denen ich einfach auf die einzelnen Tabellenblätter referenzieren kann. Diese kännte man noch auf nothing setzen, wenn man sie nicht mehr braucht, fällt hier aber aus, da sie solange gelten sollen, wie die Datei offen ist.
Danach besorge ich mir so wie die Variablennamen ja schon sagen die letzte Zeile und Spalte ( da ich sie evtl zum Zeitpunkt des Programmierens nicht kenne) Z für Ziel Q für Quelle
Dann durchlauufe ich alle Zeile von 8 an (for i)
Find sucht im angegebenen Bereich (strRange) nach dem Wert der in der Zeile in Spalte 2 (B) der Quelle steht (wksQ.Cells(i, 2).Value)
Der Rückgabewert ist ein Range (siehe Hilfedatei von excel). Wenn nichts gefudnen wurde ist der Wert nothing, daher die folgende if Abfrage
Dann merke ich mir die Reihe die ich gefunden habe
Jetzt durchlaufe ich Spaltenweise von 8 (H) an bis zur letzten Spalte (for j)
wenn ich in der aktuellen Zeile (i) und der aktuellen Spalte (j) in der quelle einen Wert "" finde dann gehts weiter
es wird wieder auf die erste Reihe des gesuchten Namens gesetzt (könnte beim ersten Durchlauf entfallen)
ich benutze bEintragen zum Steuern, also erstmal false (noch nicht eingetragen)
solange noch nicht eingetragen mache folgendes
wenn in der durchsuchten Reihe in der aktuellen spalte kein Wert steht: eintragen und steuervariable für Schleife setzen
sonst Reihe um 1 erhöhen und Abfrage ob immer noch der richtige Name in der neuen Zeile vorhanden ist.
und das für jede Spalte (for j)
und in jeder Zeile (for i)
Geh es mal schritt für Schritt (F8) im VBA Editor durch und lass dir die Variablen anzeigen, dann siehst du was passiert, ist kein Hexenwerk ;-)
Ich hoffe so wird es klarer
Gruß
yummi

Hallo Yummi,
eine Sache ist mir eben aufgefallen. Wie kann ich das eleganter lösen:
Ich hatte ja, statt der MsgBox "Zu wenig Zeilen" neue Zeilen eingefügt. Dadurch ändert sich ja die letzte Zeile (lletzeZeileZ) und das Makro durchläuft nicht mehr alle Zeilen. Also die letzten Zeilen werden nicht mehr ausgefüllt.
Das liegt daran:


strRange = "B7:B" & lletzteZeileZ

Kann es sein, dass lletzteZeileZ auf die letzte Zeile VOR einfügen der Zeilen festgelegt wird? Wie kann ich das dynamisch gestalten, so dass auch beim Durchlaufen der letzten Schleife alle Zeilen gepürft und in meinem Fall mit Daten befüllt werden.
Ich habe das jetzt mal so gelöst:


strRange = "B7:B500"

Da ich bei meinen aktuellen Daten weiß, dass ich weniger als 500 Zeilen brauche. Aber elegant und "safe" ist das auch nicht, sollten sich die Daten mal erhöhen.
Danke!
Viele Grüße,
Jasmin
Hier nochmal der ganze Code:


Option Explicit
Dim wkb As Workbook
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Sub MAProjektübersicht()
Dim i As Long
Dim j As Integer
Dim lletzteZeileQ As Long
Dim lletzteZeileZ As Long
Dim lletzteSpalteQ As Long
Dim lletzteSpalteZ As Long
'Q steht für Quelldaten, Z für Zieldaten
Dim strRange As String
Dim rng As Range
Dim bEingetragen As Boolean
Dim lreihe As Long
Dim lReiheErste As Long
Initialisiere
lletzteZeileQ = wksQ.Cells(Rows.Count, 2).End(xlUp).Row
lletzteZeileZ = wksZ.Cells(Rows.Count, 2).End(xlUp).Row
lletzteSpalteQ = wksQ.Cells(7, 256).End(xlToLeft).Column
lletzteSpalteZ = wksZ.Cells(7, 256).End(xlToLeft).Column
'    strRange = "B7:B" & lletzteZeileZ
strRange = "B7:B500"
wksZ.Activate
For i = 8 To lletzteZeileQ
Set rng = wksZ.Range(strRange).Find(wksQ.Cells(i, 2).Value)
If Not rng Is Nothing Then
lreihe = rng.Row
lReiheErste = lreihe
For j = 8 To lletzteSpalteQ
If wksQ.Cells(i, j).Value  "" Then
lreihe = lReiheErste
bEingetragen = False
Do While bEingetragen = False
If wksZ.Cells(lreihe, j).Value = "" Then
bEingetragen = True
wksZ.Cells(lreihe, j).Value = wksQ.Cells(i, j).Value
Else
lreihe = lreihe + 1
If wksZ.Cells(lreihe, 2).Value  wksQ.Cells(i, 2).Value Then
wksZ.Rows(lreihe & ":" & lreihe).Insert Shift:=xlDown, CopyOrigin:= _
xlFormatFromLeftOrAbove
wksZ.Cells(lreihe, 2).Value = wksQ.Cells(i, 2).Value
wksZ.Cells(lreihe, 2).Interior.Color = 255
End If
End If
Loop
End If
Next j
End If
Next i
wksZ.Range("H8:AI1048576").WrapText = True
wksZ.Rows("8:1048576").RowHeight = 12
End Sub
Function Initialisiere()
Set wkb = ThisWorkbook
Set wksQ = wkb.Sheets("Details_MA")
Set wksZ = wkb.Sheets("Projektübersicht")   'hier anpassen
End Function

If wksZ.Cells(lreihe, 2).Value wksQ.Cells(i, 2).Value Then wksZ.Rows(lreihe & ":" & lreihe).Insert Shift:=xlDown, CopyOrigin:= _ _ xlFormatFromLeftOrAbove wksZ.Cells(lreihe, 2).Value = wksQ.Cells(i, 2).Value wksZ.Cells(lreihe, 2).Interior.Color = 255 lletzteZeileZ = lletzteZeileZ + 1 End If

Beliebteste Forumthreads (12 Monate)

VBA "sverweis" aber ohne 0 Ergebnisse

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA "sverweis" aber ohne 0 Ergebnisse

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread