VBA Anpassing, mit 1 Zeilen und X Spalte

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub filtern() Dim C As Range, wS As Worksheet, wS2 As Worksheet, x As Long, y As Long, z As Long Set wS = ThisWorkbook.Worksheets("Lager") Set wS2 = ThisWorkbook.Worksheets.Add x = 2: z = 2 With wS2 For Each C In wS.Range("B6:B100") If C = 1 Then .Cells(x, 1) = C.Offset(0, 1) For y = 4 To 8 If LCase(wS.Cells(1, y)) = "x" Then .Cells(x, z) = wS.Cells(C.Row, y) z = z + 1 End If Next y x = x + 1: z = 2 End If Next C z = 2 For y = 4 To 8 If wS.Cells(1, y) "" Then .Cells(1, z) = wS.Cells(4, y) z = z + 1 End If Next y .Rows(1).WrapText = False .Columns("A:Z").AutoFit End With End Sub

Hallo Boris,
Das sieht schon gut aus, aber mir ist ein Fehler im Beschreibung unterlaufen und wenn geht noch einen änderung
es sollte nur die spalte kopiert werden die ein X haben jetzz wird spalte c auch übertragen dies sollte nicht sein.
und wie im Bespieldatei: Dialogfenster "Speichern unter" mit Tabelleblat name die im Zelle J2 geschrieben ist, Tabellenblatt wird als Datei gespeichert.
und als extra wünsch wenn's geht:-) nach kopieren in Tabellenblatt Lager Spalte B wert 1 ersetzen/überschreiben mit wert 2 hintergrund da bedingetn Formatierung Ampelstatus.
Deine Code hab ich so gut wie es geht für mich kommentiert aber kopieren Spalte C hab ich nicht geschafft zu unterbinden


Sub filtern()
Dim C As Range, wS As Worksheet, wS2 As Worksheet, x As Long, y As Long, z As Long
Set wS = ThisWorkbook.Worksheets("Lager")
Set wS2 = ThisWorkbook.Worksheets.Add
x = 2: z = 2
With wS2
For Each C In wS.Range("B6:B100") 'Zellbereich
If C = 1 Then   'wenn 1
.Cells(x, 1) = C.Offset(0, 1) 'erste(1)Zeile X
For y = 4 To 8   'Spalten bereich
If LCase(wS.Cells(1, y)) = "x" Then
.Cells(x, z) = wS.Cells(C.Row, y)
z = z + 1
End If
Next y
x = x + 1: z = 2 'Spalte
End If
Next C
z = 1
For y = 4 To 8 'Spalten bereich
If wS.Cells(1, y)  "" Then
.Cells(1, z) = wS.Cells(4, y) 'Zeile 4 kopieren neue tabellenblatt nach zeile 1
z = z + 1 'Spalte
End If
Next y
.Rows(1).WrapText = False
.Columns("A:Z").AutoFit
End With
End Sub

Beste Grüße
Hans

Sub filtern() Dim C As Range, wS As Worksheet, wS2 As Worksheet Dim WBName As String, x As Long, y As Long, z As Long Set wS = ThisWorkbook.Worksheets("Lager") Set wS2 = ThisWorkbook.Worksheets.Add WBName = wS.Range("J2").Value x = 2: z = 2 With wS2 For Each C In wS.Range("B6:B100") 'Zellbereich If C = 1 Then 'wenn 1 For y = 4 To 8 'Spalten bereich If UCase(wS.Cells(1, y)) = "X" Then .Cells(z, x) = wS.Cells(C.Row, y) x = x + 1 End If Next y z = z + 1: x = 2 'Spalte C.Value = 2 End If Next C For y = 4 To 8 'Spalten bereich If wS.Cells(1, y) "" Then .Cells(1, x) = wS.Cells(4, y) 'Zeile 4 kopieren neue tabellenblatt nach zeile 1 x = x + 1 'Spalte End If Next y .Cells.WrapText = False .Columns("A:Z").AutoFit .Copy 'AktiveSheet kopieren ActiveWorkbook.SaveAs WBName ActiveWorkbook.Close End With End Sub

Beliebteste Forumthreads (12 Monate)

VBA Anpassing, mit 1 Zeilen und X Spalte

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Anpassing, mit 1 Zeilen und X Spalte

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread