Kopieren von Daten von Wb1 nach Wb2

Hallo
das Problem ist nicht das schöde Kopieren, sondern folgender Sachverhalt:
Erstmal das Setting
1. Die beiden Dateien sind bereits geöffnet.
2. In WB1 ist auf Blatt 1 ein Pull-Down Menü mit den Monaten. Der Anwender soll einen Monat auswählen.
3. WB2 hat 12 Blätter nach Monaten benannt
Dann zu VBA:
1. Es soll zu WB2 gesprungen werden. Und zwar genau zu dem Blatt, das dem Monat entspricht, welcher in WB1 ausgewählt wurde. Es soll die Range D6:AH6 kopiert werden.
2. Es soll zurück zu WB1 gesprungen werden, zu Blatt 3. Ab E5 soll die Auwahl eingefügt werden aber transponiert!
3. Dann soll wieder zurück auf WB2 gesprungen werden, aber mit der Range D7:AH7 zum kopieren.
4. Zurück zu WB1, diesmal zu Blatt 4, dann wieder transponieren. usw.
5. Dies soll insgesamt 15 mal Durchlaufen.
Und was ich gar nicht hinkriege:
Der Startpunkt der Selection zum Einfügen ist E5 wie oben beschrieben. Dies gilt aber nur für den Januar.
Wird Februar ausgwählt ist der Startpunkt E46, bei März E87 usw, also immer 41 Zeilen dazu.
Es wäre eine Riesenhilfe!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Georg,
ich verwende zum Zippen übrigens gerne 7zip: http://www.7-zip.de/
Anbei beide Dateien mit "in sich unveränderten Namen": https://www.herber.de/bbs/user/110644.zip
Es fällt auf, daß Du "inkonsistente" Namen verwendest: in der 110625 steht in Daten & Abr. MA1, MA2, ebenso die Blattnamen. In 110626 steht je ein Leerzeichen zwischen MA und der Nr. - so geht's nicht.
Ich habe in Letzterer bei ein paar Daten das Leerzeichen zum Testen entfernt. Man könnte dort eine weitere Spalte mit abgekürzten Namen einfügen und diese als Blattnamen verwenden - das erfordert nur ein paar wenige Änderungen im Makro, die Du evtl. selbst hinbekommst.
Im Moment sieht es so aus:

Option Explicit
Sub kopieren()
Dim z&, s&, abZ&     ' & = as long; m:Monat,z:Zeile,s:Spalte,abZ:ab Zeile
Dim mNr&             ' Nr. des Monats
Dim a, aT            ' ohne = as Variant; als Array; aT: transp. Daten
Dim eNr&             ' zwischengespeicherte err.number
Dim d2$, m$          ' $ = as string; d2: 2. Datei(Name), m: Monat
Dim t0 As Single     ' mal sehen, wie lange es dauert
t0 = Timer
d2 = "110626.xlsx"   ' hier entsprechend anpassen
' Du kannst den Namen hier "fest verdrahten" oder Du steckst ihn beim
' Öffnen der Datei (das Makro hast Du ja offensichtlich bereits) in eine
' bestimmte Zeile in "Abr" und liest ihn von dort ein, z.B. d2 = Range("R9")
' Angabe ohne Pfad genügt i.d.R.
' Array für transp. Ausgabe dimensionieren
ReDim aT(1 To 31, 1 To 1)
Range("r18:s100").ClearContents ' Ausgabebereich leeren
' Daten für Import aus Blatt "Abr" übernehmen
m = Range("s14").Value
If Trim(m) = "" Then MsgBox "kein Monat: Abbruch": Exit Sub
abZ = Range("s16").Value: mNr = Range("r16").Value
Windows(d2).Activate ' hier evtl. auch Fehlerbehandlung
On Error Resume Next
a = Sheets(m).Range("B6:AG25") ' immer 31 Tage - könnte man aber "flexibilisieren"
eNr = Err.Number        ' FehlerNr. zwischenspeichern
On Error GoTo 0
ThisWorkbook.Activate ' ist immer die Datei, die das Makro enthält
If eNr  0 Then MsgBox "Fehler: " & Err.Number & " Abbruch.": Exit Sub
For z = 1 To UBound(a)
If Trim(a(z, 1)) = "" Then
Exit For
Else
For s = 1 To 31: aT(s, 1) = a(z, s + 1): Next
'         Stop
On Error Resume Next
Sheets(a(z, 1)).Range("E" & abZ).Resize(31) = aT
eNr = Err.Number
On Error GoTo 0
If eNr = 0 Then a(z, 2) = "ok" Else a(z, 2) = "n.v."
End If
Next
Range("r18").Resize(z - 1, 2) = a
MsgBox "fertig in " & Round((Timer - t0) * 1000, 3) & " ms."
End Sub

Geht mit den paar Testdaten ratz-fatz.
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

Kopieren von Daten von Wb1 nach Wb2

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread