Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Spalte A und E aus allen Blätern zusammenkopieren

Spalte A und E aus allen Blätern zusammenkopieren
26.03.2009 17:01:20
Mindjogger
Servus,
ich möchte aus einer Excel Datei aus allen darin enthaltenen Blättern jeweils die Spalte A und E in eine neue Excel Datei auf ein Sheet kopieren.
Oder noch genauer:
ich möchte aus einer Excel Datei aus allen darin enthaltenen Blättern jeweils ein Schlüsselwort (unique) als Spaltenüberschrift finden (muß nicht Zeile 1 sein, kann auch in Zeile x sein) und den Inhalt dieser Spalte vom Schlüsselwort bis zum Ende (kann leere Felder dazwischen entwhalten) jeweils in eine neue Excel Datei auf ein gemeinsames Tabellen-Blatt zusammenkopieren.
Hat jemand eine Idee wie ich da hinbekomme?
Gruß
Bernhard

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Spalte A und E aus allen Blätern zusammenkopieren
26.03.2009 18:20:41
fcs
Hallo Bernhard,
geht etwa so.
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
SpalteNeu = SpalteNeu + 1
With wksQ
.Range(rngTitel.Offset(1, 0), .Cells(.Rows.Count, rngTitel.Column).End(xlUp)).Copy
End With
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlFormats
wksNeu.Cells(1, SpalteNeu).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If
Next
End If
End Sub


Anzeige
AW: Spalte A und E aus allen Blätern zusammenkopieren
26.03.2009 18:35:13
Mindjogger
Wow,
danke das tut. Soger mit Platzhalter *. Ich bin beeindruckt.
Kann ich nun auch in / von jedem Blatt die Spalte A passend links daneben kopieren?
Gruss
Bernhard
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


Anzeige

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige