Bei mir tritt immer 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!
Kann man das Problem nicht so lösen, dass er bei den weiteren Suchvorgängen immer in die nächste Freie Zeile schreibt?
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
Beispieldatei ist hier:
https://www.herber.de/bbs/user/28876.xls
Danke und Gruß, Dominik