Zellen kopieren aus Autofilter
31.08.2020 12:41:52
Dennis
ich bräuchte mal eine kleine Hilfe. In einer Tabelle suche ich nach einem Begriff (kommt nur 1-mal vor). Danach blende ich ein paar Sachen aus, da ich nicht alle Informationen benötige. Die Daten kopiere ich jetzt einzeln in eine Zieltabelle. Einzeln mache ich es, weil in der Zieltabelle verbundene Zellen sind. Das funktioniert auch. Jetzt mein Problem:
Ich will 6 Spalten bzw. Zellen kopieren (hier im Code auf 3 gekürzt), aber es wird 6mal die erste Zelle kopiert. Wo ist mein Fehler?
Wenn eine Beispieldatei benötigt wird, stelle ich gerne eine zur Verfügung.
Vg und danke im voraus!
Sub Kopieren()
Dim lngZeileMax As Integer
Set tp = Worksheets("Übersicht")
Set tv = Worksheets("Daten")
Set tm = Worksheets("Ziel")
With Worksheets("Übersicht")
lngRowMax = .Cells(.Rows.Count, 2).End(xlUp).Row
m = 28
For n = 12 To lngRowMax
If .Cells(n, 12).Value "" Then
a = Sheet12.Cells(n, 2).Value
Set alldata = tv.Range(tv.Cells(1, 1), tv.Cells(1, 6))
alldata.AutoFilter Field:=2, Criteria1:=a
tv.Columns(2).EntireColumn.Hidden = True
tv.Rows(1).EntireRow.Hidden = True
CustNr = tv.Cells(2, 1).SpecialCells(xlCellTypeVisible).Value
tm.Cells(m, 4) = CustNr
Descrip = tv.Cells(2, 3).SpecialCells(xlCellTypeVisible).Value
tm.Cells(m, 13) = Descrip
Qty = tv.Cells(2, 4).SpecialCells(xlCellTypeVisible).Value
tm.Cells(m, 22) = Qty
ResetAutoFilter
m = m + 2
Else
End If
Next
End With
End Sub
Sub ResetAutoFilter()
Set tp = Worksheets("Daten")
On Error Resume Next
tp.AutoFilterMode = False
tp.Columns(2).EntireColumn.Hidden = False
tp.Rows(1).EntireRow.Hidden = False
tp.ShowAllData
On Error GoTo 0
End Sub
Anzeige