Anzeige
Archiv - Navigation
1536to1540
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

X Tabellen inhalte in die erste Tabelle einlesen

X Tabellen inhalte in die erste Tabelle einlesen
02.02.2017 21:50:45
Claus
Hallo
und Guten Abend zusammen.
Ich versuche schon ewig x Tabellen deren Inhalt in eine einzige Tabelle zu kopieren.
Das funktioniert auch, aber es ist mir ehrlich gesagt zu aufwendig,das jedes mal anzupassen und zu erweitern, da sich die Tabellen immer ein wenig ändern können.
Ich habe hier ein Auszug des VS Script um es Bildlich darzustellen.
Sub Test02()
Dim Bereich, Berich1 As Range
Set Bereich = Worksheets("3").Range("A5:K107")
Bereich.Copy Destination:=Worksheets("K1").Range("A3")
Set Bereich = Worksheets("4").Range("A5:K107")
Bereich.Copy Destination:=Worksheets("K1").Range("A106")
Set Bereich = Worksheets("5").Range("A5:K107")
Bereich.Copy Destination:=Worksheets("K1").Range("A206")
Set Bereich = Worksheets("6").Range("A5:K107")
das sind über 350 Tabellen und ich komme einfach nicht dahinter wie ich es mit ein paar Zeilen vereinfachen kann.
Dieser Wert ("A5:K107") kann sich ändern.
Ich hoffe das ein "Fuchs" mir hier mit ein paar Tips oder ein kleines Script helfen kann.
Schon mal Danke an alle.
mfg
Claus

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: nur geraten
02.02.2017 22:01:16
Fennek
Hallo,
da viele m.E. notwendige Infos fehlen:

sub Geraten()
lr = 3
for i = 3 to sheets.count
sheets(i).Range("A5:K107").copy sheets("K1").cells(lr, "A")
lr = sheets("K1").cells(rows.count, "A").end(xlup).row
next i
end sub
mfg
AW: nur geraten
02.02.2017 22:20:48
Anton
Hallo Claus,
hier auch noch eine Lösung:
Sub InEinBlattKopieren()
Dim wksBlatt As Worksheet
Dim wksZiel As Worksheet
Dim wkbMappe As Workbook
Dim lngZMax As Long
Set wkbMappe = ThisWorkbook
Set wksZiel = wkbMappe.Worksheets("K1")
lngZMax = 3
With wksZiel
For Each wksBlatt In wkbMappe.Worksheets
If Not wksBlatt.Name = "K1" Then
wksBlatt.Range("A5:K107").Copy .Range("A" & lngZMax)
lngZMax = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End If
Next wksBlatt
End With
End Sub
VG Anton
Anzeige
AW: nur geraten
02.02.2017 22:22:54
Claus
Hallo
Okay, kann ich verstehen, ich habe eine Beispiel Datei angefügt, ev. Hilft das.
In der "Ersten" Tabelle ( K1 ) sollen die Werte von den Tabellen 3 bix x per VB automatisch in K1 untereinander eingetragen werden.
https://www.herber.de/bbs/user/111117.xlsx
AW: nur geraten
02.02.2017 22:36:45
Anton
Nochmal angepasst. Aber eigentlich haargenau das gleiceh wie von Fennek.
Sub InEinBlattKopieren()
Dim i As Long
Dim wksZiel As Worksheet
Dim wkbMappe As Workbook
Dim lngZMax As Long
Set wkbMappe = ThisWorkbook
Set wksZiel = wkbMappe.Worksheets("K1")
lngZMax = 3
With wksZiel
For i = 3 To wkbMappe.Worksheets.Count
Worksheets(i).Range("A5:K107").Copy .Range("A" & lngZMax)
lngZMax = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Next i
End With
End Sub

Anzeige
AW: nur geraten
02.02.2017 23:03:59
Claus
Hallo an alle Unterstützer.
Ups, vielen Dank
habe das Problem, Danke eurer Hilfe lösen können.
Grins, ich freu mich das Ihr mir Helfen konntet.
Danke an alle.
:- :-)
Mfg
Claus
AW: nur geraten
02.02.2017 23:06:25
Anton
Jetzt habe ich grad noch was für Deine Beispielmappe vorbereitet :)
Sub InEinBlattKopieren()
Dim wksBlatt As Worksheet
Dim wksZiel As Worksheet
Dim wkbMappe As Workbook
Dim lngZMaxZiel As Long
Dim lngZMax As Long
Set wkbMappe = ThisWorkbook
Set wksZiel = wkbMappe.Worksheets("K1")
lngZMaxZiel = 2
For Each wksBlatt In wkbMappe.Worksheets
If Not wksBlatt.Name = "K1" Then
With wksBlatt
lngZMax = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:A" & lngZMax).Copy wksZiel.Range("A" & lngZMaxZiel)
.Range("B2:B" & lngZMax).Copy wksZiel.Range("B" & lngZMaxZiel)
.Range("C2:C" & lngZMax).Copy wksZiel.Range("C" & lngZMaxZiel)
.Range("D2:D" & lngZMax).Copy wksZiel.Range("D" & lngZMaxZiel)
lngZMaxZiel = wksZiel.Cells(wksZiel.Rows.Count, 1).End(xlUp).Row + 1
End With
End If
Next wksBlatt
End Sub

Anzeige
AW: nur geraten
03.02.2017 19:47:40
Claus
Hallo an alle Unterstützer.
Ups, vielen Dank
habe das Problem, Danke eurer Hilfe lösen können.
Grins, ich freu mich das Ihr mir Helfen konntet.
Danke an alle.
:- :-)
Mfg
Claus
AW: noch einmal geraten
03.02.2017 10:07:53
Fennek
Hallo,
nach Ansicht der Tabelle, aber ohne Test:

sub Geraten()
lr = 3
'for i = 3 to sheets.count
for each WS in thisworkbook.Sheets
if WS.Name >= 3 then
Ws.Range("A5:K107").copy sheets("K1").cells(lr, "A")
lr = WS.cells(rows.count, "A").end(xlup).row + 1
end if
next i
end sub
Es soll eh nur Hilfe zur Selbsthilfe sein.
mfg

303 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige