AW: Gefilterte Liste sichtbare Zeilen kopieren
01.12.2005 12:26:26
Marcus
Hallo! Erstmal Danke für die Antworten!
Ich poste mal den Code, so wie ich ihn im Programm habe:
Sub BestNeu()
Dim test As Integer
Dim test1 As Integer
Dim lngFilterRow As Long, lngFilterColumn As Long
Dim lngFilter As Long
With Application
.DisplayAlerts = False 'Meldungen aus
.EnableEvents = False 'Ereignisprozeduren aus
.ScreenUpdating = False 'Bildschirmflackern aus
End With
For test1 = 1 To Sheets.Count
If Sheets(test1).Name = "Bestelldaten" Then Sheets(test1).Delete
Next test1
Application.DisplayAlerts = True 'Meldungen ein
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Bestelldaten"
'____________________________
' Formblatt erstellen
Range("A1").Select
ActiveCell.FormulaR1C1 = "Lieferant:"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Dell"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Beschreibung"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Bestell-Code"
Range("D2").Select
ActiveCell.FormulaR1C1 = "ArtNr. Lieferer"
Range("E2").Select
ActiveCell.FormulaR1C1 = "ArtNr. Hersteller"
Range("G2").Select
ActiveCell.FormulaR1C1 = "im Korb"
Range("A1:I2").Select
Selection.Copy
Range("A5").Select
ActiveSheet.Paste
Range("A9").Select
ActiveSheet.Paste
Range("A13").Select
ActiveSheet.Paste
Range("A17").Select
ActiveSheet.Paste
Range("A21").Select
ActiveSheet.Paste
Range("A25").Select
ActiveSheet.Paste
Range("b5").Select
ActiveCell.FormulaR1C1 = "Ingram"
Range("b9").Select
ActiveCell.FormulaR1C1 = "Combo"
Range("b13").Select
ActiveCell.FormulaR1C1 = "Wortmann"
Range("b17").Select
ActiveCell.FormulaR1C1 = "Ergotron"
Range("b21").Select
ActiveCell.FormulaR1C1 = "IDS"
Range("b25").Select
ActiveCell.FormulaR1C1 = "Secomp"
Range("a1:b1").Font.Bold = True
Range("a1:b1").Font.Size = 12
Range("a5:b5").Font.Bold = True
Range("a5:b4").Font.Size = 12
Range("a9:b9").Font.Bold = True
Range("a9:b9").Font.Size = 12
Range("a13:b13").Font.Bold = True
Range("a13:b13").Font.Size = 12
Range("a17:b17").Font.Bold = True
Range("a17:b17").Font.Size = 12
Range("a21:b21").Font.Bold = True
Range("a21:b21").Font.Size = 12
Range("a25:b25").Font.Bold = True
Range("a25:b25").Font.Size = 12
Range("a2:g2").Font.Bold = True
Range("a6:g6").Font.Bold = True
Range("a10:g10").Font.Bold = True
Range("a14:g13").Font.Bold = True
Range("a18:g18").Font.Bold = True
Range("a22:g22").Font.Bold = True
Range("a26:g26").Font.Bold = True
Range("A:A").EntireColumn.ColumnWidth = 22.86
Range("F:F").EntireColumn.ColumnWidth = 5.43
For test = 1 To Sheets.Count
If Sheets(test).Name = "Temp" Then Sheets(test).Delete
Next test
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Temp"
'______________________
'Server durchsuchen
Worksheets("Server").Select
If Not ActiveSheet.AutoFilterMode = True _
Then Columns("L:L").AutoFilter
For j = 1 To 7
Select Case j
Case 1
b = "1"
Case 2
b = "2"
Case 3
b = "3"
Case 4
b = "4"
Case 5
b = "5"
Case 6
b = "6"
Case 7
b = "7"
End Select
If WorksheetFunction.CountIf(Range("L:L"), b) > 0 Then
Selection.AutoFilter Field:=1, Criteria1:=b
End If
With Worksheets("Server")
If .AutoFilterMode Then
If .FilterMode Then
With .AutoFilter
lngFilterRow = .Range.Row
lngFilterColumn = .Range.Column
With .Filters
For lngFilter = 1 To .Count
If .Item(lngFilter).On Then Exit For
Next
End With
End With
.Range(.Range(.Cells(lngFilterRow + 1, lngFilterColumn), _
.Cells(lngFilterRow + 1, lngFilterColumn + .AutoFilter.Filters.Count - 1)), _
.Cells(lngFilterRow, lngFilter).End(xlDown)).Copy _
Worksheets("Temp").Range("A65536").End(xlUp).Offset(1, 0)
End If
End If
End With
Worksheets("Server").Select
Next j
ActiveSheet.AutoFilterMode = False
'______________________
'ServerZusätze durchsuchen
'______________________
'Workstation durchsuchen
End Sub
Es tritt immernoch folgendes Problem auf:
Tabelle "Server" wir nach der Zahl 1 durchsucht, das ganze wird in Tabelle "Bestelldaten" kopiert.
Nun wird Tabelle "Server" nach Zahl 2 durchsucht, und das ganze wird in "Bestelldaten" kopiert, überschreibt jedoch die Kopien aus den ersten Vorgängen!
Wenn wir das abschaffen könnten wäre mein Problem gelöst :)
Beispieldatei ist hier:
https://www.herber.de/bbs/user/28876.xls
Danke und Gruß!