VBA - Daten transportieren | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Berndt,
weil Du so freundlich schreibst: machbar ist so gut wie alles, fragt sich nur, mit welchem Aufwand...
Das Forum ist nicht dazu da, Programmieraufträge nach Kundenwünschen zu auszuführen, sondern Fragen zu beantworten.
Ich habe mal den ersten Punkt programmiert: das Übertragen in die einzelnen Blätter.
Ich habe die Reihenfolge der Spalten geändert und eine weitere eingeführt, in die ein "ja" geschrieben wird, sobald die Übertragung vorgenommen wurde: DIESE Spalte kannst Du dann verwenden, um Zeilen im "Themenspeicher" zu löschen (d.h. Du mußt Dein Makro entsprechend selbst ändern).
Vielleicht hilft Dir die Vorgehensweise ja schon, um die weiteren Sachen geregelt zu bekommen.
Die Datei:

Die Datei https://www.herber.de/bbs/user/108228.xlsm wurde aus Datenschutzgründen gelöscht

Schöne Grüße,
Michael

Private Sub CommandButton3_Click() Dim i&, k&, a ', b ' i und z braucht man immer, a+b sind "Arrays" Dim bis& ' & = as long Const von = 6 ' erste Zeile mit Daten bis = Range("B" & Rows.Count).End(xlUp).Row + 1 a = Range("B" & von & ":E" & bis) For i = 1 To UBound(a) If a(i, 2) = "x" Then bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1 ' 2000 reicht hier ja... Sheets(a(i, 3)).Range("B" & bis) = a(i, 1) Sheets(a(i, 3)).Range("C" & bis) = a(i, 4) End If Next End Sub

Private Sub CommandButton3_Click() Dim i&, k&, a Dim bis& ' & = as long Const von = 6 ' erste Zeile mit Daten bis = Range("B" & Rows.Count).End(xlUp).Row + 1 a = Range("B" & von & ":E" & bis) For i = 1 To UBound(a) If a(i, 2) = "x" Then bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1 ' 2000 reicht hier ja... Sheets(a(i, 3)).Range("B" & bis) = a(i, 1) Sheets(a(i, 3)).Range("C" & bis) = a(i, 4) Sheets(a(i, 3)).Range("B9:C9").Copy ' da ist das gleiche Format Sheets(a(i, 3)).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats End If Next End Sub

Also vielen Dank nochmal. Es funktioniert super.
Allerdings stellt sich für mich immer noch die Frage, wie die Daten wieder zusammenzuführen sind in das Template Dashboard.
Mein (nicht funktionierender) erster Vorschlag:

Private Sub CommandButton3_Click()
Dim i&, k&, a     ' i und z braucht man immer, a+b sind "Arrays"
Dim bis&          ' & = as long
Const von = 6     ' erste Zeile mit Daten
Application.ScreenUpdating = False
bis = Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":E" & bis)
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1 ' 2000 reicht hier ja...
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B1:B" & bis), 0)) Then
Sheets(a(i, 3)).Range("B" & bis) = a(i, 1)
Sheets(a(i, 3)).Range("C" & bis) = a(i, 4)
Sheets(a(i, 3)).Range("B8:C8").Copy  ' da ist das gleiche Format
Sheets(a(i, 3)).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
End If
End If
Next
  For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets(a("Dashboard")).Range("B2000").End(xlUp).Row + 1
If IsError(Application.Match(a(i, 1), Worksheets(a("Dashboard")).Range("B1:B" & bis), 0) _
)   Then
Sheets(a("Dashboard")).Range("B" & bis) = a(i, 1)
Sheets(a("Dashboard")).Range("E" & bis) = a(i, 4)
Sheets(a("Dashboard")).Range("F" & bis) = a(i, 3)
End If
End If
Next
Application.ScreenUpdating = True
End Sub

VG Berndt

Beliebteste Forumthreads (12 Monate)

VBA - Daten transportieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Daten transportieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread