AW: Spalte A und E aus allen Blätern zusammenkopieren
27.03.2009 09:34:33
fcs
Hallo Bernhard,
die Werte aus Spalte A zusätzlich zu kopieren ist kein Problem.
Das der Platzhalter "*" funktioniert war nicht explizit beabsichtigt. Das ist integraler Bestandteil der Find-Methode. Übrigens funktioniert auch das "?" als Platzhalter für ein einzelnes Zeichen.
Gruß
Franz
Sub SpaltenKopieren()
'Sucht das eingebene Schlüsselwort in allen Blättern _
und kopiert Inhalte der Spalte unterhalb Schlüsselwort in neues Blatt neben einander
Dim wbAktiv As Workbook, wbNeu As Workbook
Dim varKey As Variant, rngTitel As Range, SpalteNeu As Long
Dim wksQ As Worksheet, wksNeu As Worksheet
varKey = InputBox("Schlüsselwort")
If varKey "" Then
Set wbAktiv = ActiveWorkbook
Set wbNeu = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wbNeu.Worksheets(1)
For Each wksQ In wbAktiv.Worksheets
Set rngTitel = wksQ.Cells.Find(what:=varKey, LookIn:=xlValues, lookat:=xlWhole)
If Not rngTitel Is Nothing Then
With wksQ
'Werte aus Spalte A kopieren
SpalteNeu = SpalteNeu + 1
.Range(rngTitel.Offset(1, -rngTitel.Column + 1), .Cells(.Rows.Count, _
rngTitel.Column).End(xlUp).Offset(0, -rngTitel.Column + 1)).Copy
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlFormats
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlValues
'Werte aus gefundener Spalte kopieren
SpalteNeu = SpalteNeu + 1
.Range(rngTitel.Offset(1, 0), .Cells(.Rows.Count, rngTitel.Column).End(xlUp)).Copy
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlFormats
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
End If
End Sub