Suchen und Kopieren über mehre Arbeitsblätter
05.11.2014 11:54:51
Benny
neulich hatte ich Hilfe bei einem Quellcode, diesen wollte ich für ein neues Projekt modifizieren.
Damals wollte ich eine bestimmte Seite durchsuchen, nun möchte ich, dass alle Seiten durchsucht werden. Leider führt For Each QuellSheet In Worksheets zu dem Fehler Die Methode Union für das Objekt _Global ist fehlgeschlagen. Könnt Ihr mir dabei Helfen?
Außerdem habe ich noch eine Frage ist es möglich den Quellcode so anzupassen das nur bestimmte Spalten einer Zeile kopiert werden?
Sub Kopiern_VerR()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim Projekt
Dim Quell As Workbook, QuellSheet As Worksheet, rngQuelle As Range
Dim rng As Range
On Error GoTo ErrorHandler:
Application.ScreenUpdating = False
Application.EnableEvents = False
Projekt = Tabelle1.Range("A1").Value
n = ActiveCell.Row
Set Quell = Workbooks.Open("R:\Allgemein\2014.xlsx")
For Each QuellSheet In Worksheets
With Tabelle1
ZeileMax = QuellSheet.UsedRange.Rows.Count
For Zeile = 2 To ZeileMax
If QuellSheet.Cells(Zeile, 10).Value = Projekt Then
If Not rngQuelle Is Nothing Then
Set rngQuelle = Union(rngQuelle, QuellSheet.Rows(Zeile))
Else
Set rngQuelle = QuellSheet.Rows(Zeile)
End If
End If
Next Zeile
If Not rngQuelle Is Nothing Then
rngQuelle.Copy
.Rows(n).PasteSpecial (xlPasteAll)
.Rows(n).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
End With
Next QuellSheet 'erzeugt fehler
ErrorHandler:
If Not Quell Is Nothing Then Quell.Close savechanges:=False
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number 0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub