Daten kopieren und zeilenweise anordnen

Hallo,
wir bekommen in regelmäßigen Abständen Berichte über Lagerbestände. (siehe Wochenbericht in angefügter Datei) Der Aufbau dieser Listen ist IMMER absolut IDENTISCH. Nur die Daten nicht :-)
Diese Daten müssen in eine Gesamtübersicht eingetragen werden, um diese wiederum per Pivot auszuwerten. (siehe Gesamtübersicht in angefügter Datei)
Ich würde das kopieren, welches im Moment noch ein MA händisch macht, gerne per Makro automatisieren.
Zeilen , in denen nur der Ort ohne weitere Daten steht, sollen nicht berücksichtigt werden.
Meine Idee war, eine Schleife zu bauen, die die Einträge aus den Wochenberichte entsprechend der Anforderungen zeilenweise in die Gesamtübersicht kopiert.
Ich habe schon ziemlich rumgebastelt, aber schaffe es nicht.
Kann mir jemand helfen?
Gruß,
Peter
Datei:
https://www.herber.de/bbs/user/95792.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub daten_extract() With Sheets(2) For Each col In .Range("B2:z2").SpecialCells(xlCellTypeConstants) For Each rw In .Range("a4:a99").SpecialCells(xlCellTypeConstants) KW = .Cells(2, col.Column) ort = .Cells(rw.Row, 1) ind = .Cells(rw.Row, col.Column) meng = .Cells(rw.Row, col.Column + 1) meng_ind = .Cells(rw.Row, col.Column + 2) With Sheets(1) lz = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(lz, 1) = ort .Cells(lz, 2) = KW .Cells(lz, 3) = meng .Cells(lz, 4) = meng_ind End With Next rw Next col End With End Sub

Hallo Peter,
den folgenden Cod in ein Modul kopieren, das kannst du dann entweder über Makros aufrugen oder legst dur noch einen Button an, wie Du willst:


Option Explicit
Sub Importiere()
Dim letzteZeileWB As Long
Dim letztezeileGesamt As Long
Dim str As String
Dim rng As Range
Dim letzteSpalteWB As Integer
Dim wksGes As Worksheet
Dim wksWB As Worksheet
Dim i As Long
Dim strRange As String
Dim iSpalte As Integer
Set wksGes = ThisWorkbook.Sheets("Gesamtliste")
Set wksWB = ThisWorkbook.Sheets("Wochenberichte")
letzteZeileWB = wksWB.Cells(wksWB.Rows.Count, 1).End(xlUp).Row
letztezeileGesamt = wksGes.Cells(wksGes.Rows.Count, 1).End(xlUp).Row + 1
letzteSpalteWB = wksWB.Cells(4, 256).End(xlToLeft).Column
str = InputBox("Welche Woche soll imporitert werden?", Default:="KW")
If InStr(1, str, "KW", vbTextCompare) = 0 Then
str = "KW " & str
End If
strRange = "A2:" & WandleZahlInBuchstaben(letzteSpalteWB) & "2"
Set rng = Sheets("Wochenberichte").Range(strRange).Find(str)
If Not rng Is Nothing Then
iSpalte = rng.Column
Set rng = Nothing
Else
MsgBox "Keinen Eintrag zu der Woche gefunden"
End If
If iSpalte  0 Then
For i = 4 To letzteZeileWB
If wksWB.Cells(i, iSpalte + 1).Value  "" Then
wksGes.Cells(letztezeileGesamt, 1).Value = wksWB.Cells(i, 1).Value
wksGes.Cells(letztezeileGesamt, 2).Value = str
wksGes.Cells(letztezeileGesamt, 3).Value = wksWB.Cells(i, iSpalte + 1).Value
wksGes.Cells(letztezeileGesamt, 4).Value = wksWB.Cells(i, iSpalte + 2).Value
letztezeileGesamt = letztezeileGesamt + 1
End If
Next i
End If
End Sub
Function WandleZahlInBuchstaben(ByVal iWert As Integer) As String
Dim Spaltenbuchstabe As String
Spaltenbuchstabe = Right(Columns(iWert).Address, _
Len(Columns(iWert).Address) - _
InStrRev(Columns(iWert).Address, "$"))
WandleZahlInBuchstaben = Spaltenbuchstabe
End Function

Gruß
yummi

Beliebteste Forumthreads (12 Monate)

	A	B	C	D
1	Lager	KW	Menge	Mengenindex
2	Köln	KW 51	8862	111
3	Düsseldorf	KW 51	16634	216
4	Frankfurt	KW 51
5	München	KW 51	12387	161
6	Wuppertal	KW 51
7	Köln	KW 52	6301	79
8	Düsseldorf	KW 52	12607	164
9	Frankfurt	KW 52
10	München	KW 52	9161	119
11	Wuppertal	KW 52
12	Köln	KW 53	4159	52
13	Düsseldorf	KW 53	8301	108
14	Frankfurt	KW 53
15	München	KW 53	6154	80
16	Wuppertal	KW 53
17	Köln	KW 01	2845	36
18	Düsseldorf	KW 01	5685	75
19	Frankfurt	KW 01
20	München	KW 01	3924	51
21	Wuppertal	KW 01
22	Köln	KW 02	8653	108
23	Düsseldorf	KW 02	16120	209
24	Frankfurt	KW 02
25	München	KW 02	12766	166
26	Wuppertal	KW 02
27	Köln	KW 03	8800	111
28	Düsseldorf	KW 03	15912	207
29	Frankfurt	KW 03
30	München	KW 03	12294	160
31	Wuppertal	KW 03
32	Köln	KW 04	8587	109
33	Düsseldorf	KW 04	16088	212
34	Frankfurt	KW 04
35	München	KW 04	12379	163
36	Wuppertal	KW 04
37	Köln	KW 05	8373	107
38	Düsseldorf	KW 05	16278	214
39	Frankfurt	KW 05
40	München	KW 05	12329	162
41	Wuppertal	KW 05

Daten kopieren und zeilenweise anordnen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten kopieren und zeilenweise anordnen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread