VBA Code verknüpfen
Ralf
ich habe eine Datei mit 11 Tabellenblättern. Aus den ersten 10
soll mir Excel immer komplette Zeilen in die 11 te Tabelle ( Archiv )
stellen, wenn in Spalte AC eine 1 zu finden ist.
Dieses funktioniert auch ganz gut mit dem Code - - - nuuuur es
ist dort eine "Ausgehbedingung" formuliert, die den gesamten
Vorgang abbricht, wenn Excel in einer Tabelle nichts findet :
'If Finden Is Nothing Then Exit Sub
Kann man den Code (s.u.) so ändern, daß Excel einfach mit dem nächsten
Tabellenblatt weitermacht ?
Mir ist es leider ( siehe Level :-) ) nicht geglückt.
:-) Grüße
Ralf
Sub sbButton1()
'Name des Buttons: Die "1" en aus Spalte AC ins Archiv
Tabelle 1
Application.ScreenUpdating = False
Dim Suchbereich As Range, Daten As Range, Finden As Range
Dim wks1 As Worksheet, Archiv As Worksheet, Adresse As String
Set wks1 = ActiveWorkbook.Sheets("Kombi_1")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 2
Set wks1 = ActiveWorkbook.Sheets("Kombi_2")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 3
Set wks1 = ActiveWorkbook.Sheets("Stephan_VM_800")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 4
Set wks1 = ActiveWorkbook.Sheets("Stephan_VM_450")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 5
Set wks1 = ActiveWorkbook.Sheets("Koruma")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 6
Set wks1 = ActiveWorkbook.Sheets("Pilot_Anla")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 7
Set wks1 = ActiveWorkbook.Sheets("Viscojet_Groß")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 8
Set wks1 = ActiveWorkbook.Sheets("Viscojet_Groß_2")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 9
Set wks1 = ActiveWorkbook.Sheets("Viscojet_klein")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Tabelle 10
Set wks1 = ActiveWorkbook.Sheets("Kuttermix_Anla")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("AC6:AC" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "AC"))
Daten.Copy
zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(zeile, "A").PasteSpecial Paste:=xlValues
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse Finden.Address
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Range("AB2").Select
End Sub