Gruppen

Top Gruppen: Windows 7; Windows Vista; Windows XP; Textverarbeitung; Excel; DSL; Internet Browser; E-Mail/Outlook
Betriebsysteme: Windows classik; Linux; BS-Sonstige
Software: Datenbanken; Bildbearbeitung; Audio/mp3/Video; Security/Viren; SW-Sonstige
Hardware: Mainboard/CPU; Grafikkarten; Peripherie; Laptop/Notebook; HW-Sonstiges
Netzwerk: Telefon,ISDN,Modem; W-Lan; NW-Sonstiges
Programmierung: PHP,ASP,Perl...; Java,C++...; Webseiten/HTML
Sonstiges: PC-Sonstiges; Plauderecke; SN Intern; Test

/ Forum / Tabellenkalkulation

Tabellenkalkulation

Fragevon wmei vom 24.02.2021, 16:18 Options

Find Funtion in VBA

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

Antwort schreiben

Antwort 1 von nighty vom 24.02.2021, 18:29 Options

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

Antwort 2 von wmei vom 25.02.2021, 10:26 Options

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

Antwort 3 von nighty vom 25.02.2021, 10:56 Options

hi charlie brown ^^

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

gruss nighty

die loesung wird dann noch gepostet

Antwort 4 von nighty vom 27.02.2021, 18:57 Options

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

Antwort 5 von nighty vom 01.03.2021, 11:58 Options

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

Antwort 6 von wmei vom 02.03.2021, 12:02 Options

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

Hinweis

Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..

Neue Einträge

Tipp einschicken

News einschicken