Spalte nach "X" absuchen und 3 Zellen kopieren

Hallo zusammen. Ich habe ein Problem und hoffe, dass mir hier jemand weiterhelfen kann. Ich habe eine Excel-Datei, bestehend aus 2 Seiten. Auf der 2. Seite (heißt bei mir "Unterweisung") habe ich mein Leerformular, welches es mittels Makro zu befallen gibt. Außerdem wähle ich hier mittels Drop-Down-Liste meine Namens-, bzw. Schichtgruppe in Zelle D4 aus (SG_A, B, C, D). Auf Seite 1 (bei mir "Übersicht") sind die 4 Schichtgruppen nebeneinander aufgelistet. Wähle ich auf Seite 2 z.B. SG_A, soll Spalte G auf Seite 1 nach "X" durchsucht werden. Von jeder Zeile ab Zeile 7 mit einem "X" in Spalte G sollen die Zellen C=Vorname, D=Nachname und E=Stammnummer kopiert und untereinander auf Seite 2 in das Leerformular kopiert werden. Der erste Vorname würde dann auf Seite 2 ("Unterweisung") in Zelle G14 stehen, der erste Nachname in Zelle H14 und die erste Stammnummer in Zelle I14.
Ziel ist es, das Drucken von Unterweisung zu vereinfachen. Man wählt seine Schichtgruppe und die zu unterweisenden Mitarbeiter aus, betätigt das Makro mittels Button, welches im Anschluss einen Druckbefehl sendet. Den Befehl zum Drucken habe ich bereits. Da mein PC zuhause den Geist aufgegeben hat und ich in der Arbeit keinen Internetzugriff habe, versuche ich es so gut wie möglich zu erklären. Einen Ausdruck meiner Mappe habe ich vor mir, die Zellen stimmen also aber jetzt weiter zu Part 2. Wichtiger ist aber der obere Teil. Für den Rest könnte ich das Makro für die anderen 3 Schichtgruppen etvl selbst umwandeln.
Die Spalten für SG_B (selbe Zeile wie SG_A) sind J,K und L (und N für "X") - SG_C sind Q, R und S (und U für "X") und SG_D sind X, Y und Z (und AB für "X"). Das wäre aber erst mal nicht so wichtig und würde ich selbst evtl auch noch hinbekommen. Das Wichtige wäre der obere Part und ich hoffe, dass mir jemand helfen kann. Wünsche noch einen schönen Montag.
Gruß Pflaume

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Schaltfläche3_Klicken() Dim Spalte As Long Dim loLetzte As Long Dim loLetzte1 As Long Select Case Sheets("Unterweisung").Range("D4").Value Case "A": Spalte = 3 Case "B": Spalte = 10 Case "C": Spalte = 17 Case "D": Spalte = 24 Case Else End Select loLetzte = Sheets("Übersicht").Cells(Rows.Count, Spalte).End(xlUp).Row loLetzte1 = Sheets("Unterweisung").Cells(Rows.Count, 7).End(xlUp).Row + 1 Application.ScreenUpdating = False With Sheets("Übersicht") Set bereich = .Range(.Cells(6, Spalte), .Cells(loLetzte, Spalte + 4)) .Range(bereich.Address).AutoFilter Field:=5, Criteria1:="x" .Range(.Cells(65536, Spalte), .Cells(7, Spalte + 2)).SpecialCells(xlCellTypeVisible).Copy _ Sheets("Unterweisung").Cells(loLetzte1, 7) If .FilterMode Then .ShowAllData .AutoFilterMode = False End If End With Application.ScreenUpdating = True End Sub

Hallo,
Excel spricht doch mit dir. Es hat dir in der Fehlermeldung gesagt, dass es an verbundenen Zellen liegt.
Du hast im Blatt "Sammelunterweisung" in Zeile 58 verbundene Zellen und damit hat der Code seine Probleme.
Lösung: Hebe den Zellverbund auf. Die gleiche Optik erhälst du wenn du anschließend alle Zellen die du vorher verbunden hattest markierst, anschließend Rechtsklick in den markierten Bereich, Zellen formatieren, Ausrichtung, und bei Horizontal "Über Auswahl zentrieren"
Danach läuft das Makro.
Ich habe noch ein paar kleine Änderungen gemacht, weil er dir sonst beim Kopieren die Formatierungen vom Blatt "Band" ins Blatt "Sammelunterweisung" übernommen hätte. Jetzt kopiert er nur die Werte.
Da ich nicht weiß, ob du zwischenzeitlich wieder Online bist schicke ich dir mal sowohl das geänderte Makro als auch deine angepasste Datei.

Sub Schaltfläche7_Klicken()
Dim Spalte As Long
Dim loLetzte As Long
Dim loLetzte1 As Long
Select Case Sheets("Sammelunterweisung").Range("D4").Value
Case "SG_A": Spalte = 3
Case "SG_B": Spalte = 10
Case "SG_C": Spalte = 17
Case "SG_D": Spalte = 24
Case Else
End Select
loLetzte = Sheets("Band").Cells(Rows.Count, Spalte).End(xlUp).Row
loLetzte1 = Sheets("Sammelunterweisung").Cells(Rows.Count, 7).End(xlUp).Row + 1
Application.ScreenUpdating = False
With Sheets("Band")
Set bereich = .Range(.Cells(6, Spalte), .Cells(loLetzte, Spalte + 4))
.Range(bereich.Address).AutoFilter Field:=5, Criteria1:="x"
.Range(.Cells(65536, Spalte), .Cells(7, Spalte + 2)).SpecialCells(xlCellTypeVisible).Copy
Sheets("Sammelunterweisung").Cells(loLetzte1, 7).PasteSpecial Paste:=xlPasteValues
Sheets("Sammelunterweisung").Range("G14").Select
Application.CutCopyMode = False
If .FilterMode Then
.ShowAllData
.AutoFilterMode = False
End If
End With
Application.ScreenUpdating = True
End Sub

https://www.herber.de/bbs/user/107665.xlsm
Gruß Werner

Private Sub Worksheet_Change(ByVal Target As Range) Dim loLetzte As Long Dim Spalte As Long Dim Bereich As Range Dim Zelle As Range If Target.Address(0, 0) = "G4" Or Target.Address(0, 0) = "N4" _ Or Target.Address(0, 0) = "U4" Or Target.Address(0, 0) = "AB4" Then Select Case Target.Address Case "$G$4": Spalte = 7 Case "$N$4": Spalte = 14 Case "$U$4": Spalte = 21 Case "$AB$4": Spalte = 28 Case Else End Select If Target.Row = 4 And Target.Column = Spalte Then loLetzte = Cells(Rows.Count, Spalte - 4).End(xlUp).Row If Target.Value = "x" Then Set Bereich = Range(Cells(7, Spalte), Cells(loLetzte, Spalte)) For Each Zelle In Bereich Zelle.Value = "x" Next Zelle ElseIf Target.Value = "" Then loLetzte = Cells(Rows.Count, Spalte).End(xlUp).Row Set Bereich = Range(Cells(7, Spalte), Cells(loLetzte, Spalte)) For Each Zelle In Bereich Zelle.ClearContents Next Zelle End If End If End If End Sub

Beliebteste Forumthreads (12 Monate)

Spalte nach "X" absuchen und 3 Zellen kopieren

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalte nach "X" absuchen und 3 Zellen kopieren

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread