Find Funtion in VBA

Question

Hallo VBA Spezialisten,
ich benötige Eure Hilfe.
Wenn in Zelle A1"Hans" steht und weiter
unten ebenfalls in Spalte A "Gretel" steht, möchte ich im Bereich A2:JX alle Zeilen kopieren, welche in der Spalte B nicht leer sind. Um sie in ein anderes Blatt einzufügen.
Nach dem Einfügen soll wieder in Spalte A nach "Hansi"
und wiederum nach "Gretel" gesucht und die selbige Prozedur wie oben durchgeführt werden.
Ich hoffe Ihr könnt mir helfen.
Besten Dank im Voraus,
wim

Answer 1

hi charlie brown ^^

registrier dich.dann kann ich dir eine pn mit meiner mail schicken und du mir dann eine musterdatei mit praezisen angaben

gruss nighty

Answer 2

Hallo nighty,
alles erledigt, Anmeldung ist erfolgt.
Wo soll ich die Datei hinstellen?
wim

Answer 3

hi charlie brown ^^

bei persönlichen mitteilungen hast du nun nachricht,mit meiner mailadresse

gruss nighty

die loesung wird dann noch gepostet

Answer 4

hi all ^^

die erste variante fuer die datenbank,weiteres duerfte nur feinarbeit sein

gruss nighty

Option Base 1
Option Explicit
Sub DatenSortiertKopieren()
Call EventsOff
Dim Lzeile As Long, Qzeile As Long, Zaehler1 As Long
Dim WksName As String
Worksheets("Daten").Activate
Lzeile = Worksheets("Daten").Cells(Rows.Count, 1).End(xlUp).Row
ReDim ArrQ(Lzeile, 1) As Variant
ArrQ() = Range("A1:A" & Lzeile)
For Zaehler1 = 2 To Lzeile
If ArrQ(Zaehler1, 1) = "Schmieranweisung" Then
WksName = "Schmierung"
Zaehler1 = Zaehler1 + 2
End If
If ArrQ(Zaehler1, 1) = "Wartungsanweisung" Then
WksName = "Wartung"
Zaehler1 = Zaehler1 + 2
End If
If Mid(ArrQ(Zaehler1, 1), 1, 7) = "Legende" Or Mid(ArrQ(Zaehler1, 1), 1, 9) = "Bemerkung" Then WksName = ""
If WksName = "Schmierung" And ArrQ(Zaehler1, 1) <> "" Or WksName = "Wartung" And ArrQ(Zaehler1, 1) <> "" Then
Qzeile = Worksheets(WksName).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Daten").Rows(Zaehler1 & ":" & Zaehler1).Copy Worksheets(WksName).Cells(Qzeile, 1)
End If
Next Zaehler1
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 5

hi all ^^

hat sich doch noch einiges geaendert :-)

fuer die datenbank

gruss nighty

Option Base 1
Option Explicit
Sub DatenSortiertKopieren()
Call EventsOff
Dim Zaehler1 As Long, Zaehler2 As Long, Zeile1 As Long, Zeile2 As Long
Dim WksName As String, Text1 As String, Text2 As String
Worksheets("Daten").Activate
ReDim ArrQ(Worksheets("Daten").Cells(Rows.Count, 1).End(xlUp).Row, 2) As Variant
ArrQ() = Range("A1:B" & Worksheets("Daten").Cells(Rows.Count, 1).End(xlUp).Row)
For Zaehler1 = 2 To UBound(ArrQ())
If UCase(ArrQ(Zaehler1, 1)) = "SCHMIERANWEISUNG" Then
WksName = "Schmierung"
Zaehler1 = Zaehler1 + 2
Zeile1 = Zaehler1
End If
If UCase(ArrQ(Zaehler1, 1)) = "WARTUNGSANWEISUNG" Then
WksName = "Wartung"
Zaehler1 = Zaehler1 + 2
Zeile1 = Zaehler1
End If
If UCase(Mid(ArrQ(Zaehler1, 1), 1, 7)) = "LEGENDE" Or UCase(Mid(ArrQ(Zaehler1, 1), 1, 9)) = "BEMERKUNG" Then
Zeile2 = Zaehler1 - 2
Worksheets("Daten").Rows(Zeile1 & ":" & Zeile2).Copy _
Worksheets(WksName).Cells(Worksheets(WksName).Cells(Rows.Count, 2).End(xlUp).Row + 1, 1)
WksName = ""
End If
Next Zaehler1
Worksheets("Schmierung").Activate
ArrQ() = Range("A1:A" & Worksheets("Schmierung").Cells(Rows.Count, 2).End(xlUp).Row)
For Zaehler1 = 2 To UBound(ArrQ())
If ArrQ(Zaehler1, 1) <> "" And ArrQ(Zaehler1, 1) <> Text1 Then
Text1 = ArrQ(Zaehler1, 1)
Zaehler2 = 2
End If
If ArrQ(Zaehler1, 1) = "" Then
If Len(CStr(Zaehler2)) = 1 Then Text2 = Mid(Text1, 1, Len(Text1) - 3) & "00" & CStr(Zaehler2)
If Len(CStr(Zaehler2)) = 2 Then Text2 = Mid(Text1, 1, Len(Text1) - 3) & "0" & CStr(Zaehler2)
Zaehler2 = Zaehler2 + 1
ArrQ(Zaehler1, 1) = Text2
End If
Next Zaehler1
Range("A1:A" & Worksheets("Schmierung").Cells(Rows.Count, 2).End(xlUp).Row) = ArrQ()
Worksheets("Wartung").Activate
ArrQ() = Range("A1:A" & Worksheets("Wartung").Cells(Rows.Count, 2).End(xlUp).Row)
For Zaehler1 = 2 To UBound(ArrQ())
If ArrQ(Zaehler1, 1) <> "" And ArrQ(Zaehler1, 1) <> Text1 Then
Text1 = ArrQ(Zaehler1, 1)
Zaehler2 = 2
End If
If ArrQ(Zaehler1, 1) = "" Then
If Len(CStr(Zaehler2)) = 1 Then Text2 = Mid(Text1, 1, Len(Text1) - 3) & "00" & CStr(Zaehler2)
If Len(CStr(Zaehler2)) = 2 Then Text2 = Mid(Text1, 1, Len(Text1) - 3) & "0" & CStr(Zaehler2)
Zaehler2 = Zaehler2 + 1
ArrQ(Zaehler1, 1) = Text2
End If
Next Zaehler1
Range("A1:A" & Worksheets("Wartung").Cells(Rows.Count, 2).End(xlUp).Row) = ArrQ()
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 6

hi nighty,
hab den Fehler gefunden, für die ausgelassenen Zeilen,
in Spalte A fehlte der Eintrag "Bemerkung: (z.B. Ölsorte der Erstbe-füllung / Erster Ölwechsel]" als Abschluß
sonst alles große Klasse
Danke
wim