Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1708to1712
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

Makro gesucht

Makro gesucht
16.08.2019 18:04:15
Stephan
Liebes Forum,
ich brauche Eure Hilfe:
Ich suche ein einfaches Makro, das mir aus einer Tabelle bestimmte Spalten ausliest und in einem neuen oder zu benennenden Arbeitsblatt untereinander schreibt.
Die beiliegende Beispieldatei veranschaulicht mein Thema, hoffentlich selbsterklärend.
https://www.herber.de/bbs/user/131463.xlsx
Danke für Eure Unterstützung!
Beste Grüße
Stephan

30
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro gesucht
16.08.2019 18:19:46
Hajo_Zi
Hallo Stephan,
das geht nicht, da eine XLSX Datei kein Makro enthalten kann.
Ich sehe keinen Grund eine Datei 2x zu speichern und den Code einzufügen.
Ich führe keine Liste unter welchem Dateinamen ich die Datei aus dem Forum gespeichert habe gespeichert habe.
Der Name steht ja im Beitrag.

Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Die Beiträge werden auch ignoriert, es erfolgt keine Antwort.
AW: Makro gesucht
16.08.2019 19:05:12
Stephan
Hallo Hajo,
danke für Deine Antwort.
Soll ich die Datei nochmal als xlsm hochladen?
Oder verstehe ich Dich falsch?
Beste Grüße
Stephan
Anzeige
AW: Makro gesucht
16.08.2019 19:56:50
Regina
Hi,
nein, Hajo Textbaustein soll Dich dazu animieren, deinen bsherigen Makroversuch hochzuladen. Makros/Codes können halt nur in xlsm-Dateien gespeicher werden.
Um Hajos-Nachricht zu übersetzen:
Zeig, was Du schon programmiert hast ....
Gruß
Regina
AW: Makro gesucht
16.08.2019 21:13:52
Stephan
Hey Regina,
danke für Deine Interpretation der Nachricht von Hajo.
Ich habe bisher noch nichts programmiert.
Ich wüsste nicht, wie ich mit einfachem Aufzeichnen hier zurecht kommen sollte.
Wenn ich das wüsste, würde ich hier nicht nachfragen.
Also im Klartext:
Ich brauche jemanden, der Spaß daran hat, mir die Zeilen gemäß meiner Vorlage zu schreiben.
Natürlich schaue ich mir den Code an und lerne gerne dazu.
Sicherlich werde ich danach schlauer sein, aber zum Können wäre es wohl noch ein weiter Weg ...
Beste Grüße und schon mal vielen Dank an denjenigen, der mich bei dieser Thematik unterstützt!
Stephan
Anzeige
AW: Makro gesucht
17.08.2019 09:15:00
Regina
Ok, ich bastel Dir mal was, wird aber erst wohl heute nachmittag klappen.
Gruß
Regina
AW: Makro gesucht
17.08.2019 09:33:36
Regina
ok, ging doch schneller:
Der Code geht von einem vorhandenen Arbeitsblatt "Neu" aus, in dessen erster zeile Überschriften stehen
Option Explicit
Public Sub Uebertrag()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
lng_zeile_quelle = 20
lng_zeile_ziel = 2
With obj_wks_quelle
Do Until .Cells(lng_zeile_quelle, 2) = ""
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = "Kommentar"
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11)
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12)
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13)
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, 16)
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = DateSerial(Year(.Cells(10, lng_spalte)),  _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) & "/" &  _
WorksheetFunction.WeekNum(DateSerial(Year(.Cells(10, lng_spalte)), Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13)), 2)
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub
Ich konnte nicht sehen, woher der Kommenztar kommen soll, daher habe ich dort einen festen Text mitlaufen lassen.
Wenn Du noch Fragen hast, melde Dich gerne.
Gruß
Regina
Anzeige
AW: Makro gesucht
17.08.2019 10:00:48
Stephan
Hey Regina,
danke für Deine Mühe!
So wie es aussieht, klappt es.
Wäre es möglich, die KW mit einem Bindestrich darzustellen und zweistellig (2019-02)? Dabei geht es vor allem um die einstelligen Monate, die lassen sortieren sich sonst immer so schlecht ;)
Ich teste es heute Nachmittag nochmal ausführlich.
Danke schonmal!
Beste Grüße
Stephan
AW: Makro gesucht
17.08.2019 10:16:35
Stephan
Hey Regina,
ein Punkt, den ich nicht beschrieben habe:
Meine Tabelle hat mehrere Blöcke.
Wenn man also die Zeilen 19-21 kopiert und ab Zeile 23 einfügt, dann wäre die Tabelle korrekt.
In dieser Form zieht sich die Tabelle nach unten weiter. Die Blocks haben dabei eine unterschiedliche Zeilenanzahl.
Wäre noch schön, wenn man die Blocküberschrift auch noch mitnehmen könnte, muss aber nicht sein.
Danke für Deine Unterstützung!
Beste Grüße
Stephan
Anzeige
AW: Makro gesucht
17.08.2019 10:23:36
Stephan
Hey Regina,
ein Punkt, den ich nicht beschrieben habe:
Meine Tabelle hat mehrere Blöcke.
Wenn man also die Zeilen 19-21 kopiert und ab Zeile 23 einfügt, dann wäre die Tabelle korrekt.
In dieser Form zieht sich die Tabelle nach unten weiter. Die Blocks haben dabei eine unterschiedliche Zeilenanzahl.
Wäre noch schön, wenn man die Blocküberschrift auch noch mitnehmen könnte, muss aber nicht sein.
Danke für Deine Unterstützung!
Beste Grüße
Stephan
AW: Makro gesucht
17.08.2019 13:30:47
Stephan
Hey Regina,
danke, das sieht sehr gut aus.
Noch drei Anregungen:
1. Es würde wahrscheinlich Sinn machen, dass das Blatt "Neu" bei jedem Übertrag vorher gecleart wird, damit nicht versehendlich alte Daten drin stehen. Ist das machbar?
2. Wäre es möglich, z.B. vor den "Baukosten" eine Leerzeile einzufügen?
3. Könnte man die Zeile "Baukosten" irgendwie farblich absetzen? Dann würde das lesen der Tabelle leichter werden, wenn man etwas sucht.
Ansonsten komme ich damit erst einmal weiter.
Wie kann ich mich erkenntlich zeigen?
Beste Grüße
Stephan
AW: Makro gesucht
17.08.2019 13:48:54
Stephan
... noch ein Schönheitsthema:
Kann man nach der jedem Kostenarten-Block (Mieten, Reinigung) noch eine Leerzeile einfügen?
Danke!!!!
Anzeige
AW: Makro gesucht
17.08.2019 14:08:59
Regina
Hi,
ich hoffe, ich habe das mit den gewünschten Leerzeilen richtig verstanden, schau Dir die Datei mal an.
Erkennlich zeigen musst Du Dich nicht, das ist "for free". Vielleicht ist der Code für Dich ja ein guter Einstieg, Dich mal mit VBA abseits des Makrorekorders auseinander zusetzen :-)
Gruß Regina
https://www.herber.de/bbs/user/131474.xlsm
AW: Makro gesucht
17.08.2019 14:36:20
Stephan
Hey Regina,
danke, das sieht sehr gut aus.
Wenn es jetzt im Blatt "Neu" noch eine Leerzeile zwischen den Zeilen 9/10, 22/23, etc. gäbe, dann wäre es wirklich perfekt.
Ich habe mir den Code schon angeschaut und kann ihn auch in Teilen verstehen bzw. anpassen.
Aber ich brauche VBA viel zu selten als dass sich ein tieferer Einstieg lohnt.
Da fehlt mir etwas die Zeit.
Aber im konkreten Fall beschäftige ich mich gerne damit und bin dankbar, wenn mir jemand etwas zeigt ;)
Beste Grüße
STephan
Anzeige
AW: Makro gesucht
17.08.2019 14:53:49
Regina
Hi,
dann hier auch für die Allgemeinheit der Code mit den (hoffentlich) richtigen Leerzeilen:

Public Sub Uebertrag()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim lng_letzte_zeile_quelle As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
obj_wks_ziel.Range("A2:H500").ClearContents       ' Hier ggf. Zeilennummer erweitern
obj_wks_ziel.Range("A2:H500").Interior.Color = xlNone
lng_zeile_quelle = 19
lng_zeile_ziel = 2
With obj_wks_quelle
lng_letzte_zeile_quelle = .Cells(1048576, 2).End(xlUp).Row
Do Until lng_zeile_quelle > lng_letzte_zeile_quelle
If .Cells(lng_zeile_quelle, 1) = "" And .Cells(lng_zeile_quelle, 2)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Range("A" & lng_zeile_ziel & ":H" & lng_zeile_ziel).Interior.Color =  _
vbYellow  ' Farbe ggf. anpassen
lng_zeile_ziel = lng_zeile_ziel + 1
ElseIf .Cells(lng_zeile_quelle, 1)  "" And .Cells(lng_zeile_quelle, 2)  "" Then
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = "Kommentar"
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11)
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12)
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13)
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, lng_spalte)
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), _
.Cells(lng_zeile_quelle, 13))
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) & "-" & _
Format(WorksheetFunction.WeekNum(DateSerial(Year(.Cells(10, lng_spalte)) _
, _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13)), 2), "00")
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_ziel = lng_zeile_ziel + 1
End If
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub

Gruß
Regina
Anzeige
AW: Makro gesucht
17.08.2019 18:09:49
Stephan
Hey Regina,
perfekt, danke vielmals!
Werde mal sehen, ob ich den Code nachvollziehen kann.
Beste Grüße
Stephan
AW: Makro gesucht
18.08.2019 02:05:39
Stephan
Hallo Regina,
habe noch eine Frage zur Berechnung der KWs:
Bei Benutzung des Datums 31.12.2019 ergibt es bei Deiner Berechnung die KW 2019-53.
Tatsächlich ist es aber die KW 2020-01.
Kannst Du das bitte nochmal checken?
Besten Dank und herzliche Grüße
Stephan
AW: Makro gesucht
18.08.2019 02:17:44
Stephan
Hey Regina,
und noch eine Frage:
würde man unter Benutzung des 31.12.2019 keinen Fälligkeitstag eingeben, dann wirft die Berechnung die KW 2020-53 aus.
Wenn kein Fälligkeitstag eingetragen ist, dann sollte besser keine Berechung der KW stattfinden oder eine Meldung kommen, dass zuerst alle Fälligkeitstage zu pflegen sind.
Ansonsten entsteht ein Fehler, der ziemlich gravierende Auswirkungen haben kann.
Kannst Du das bitte auch noch checken?
Ansonsten läuft alles prima ;)
Beste Grüße
STephan
Anzeige
AW: Makro gesucht
18.08.2019 10:22:44
Regina
Hi,
dann probier mal so:
Option Explicit
Public Sub Uebertrag()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim lng_letzte_zeile_quelle As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
obj_wks_ziel.Range("A2:H500").ClearContents       ' Hier ggf. Zeilennummer erweitern
obj_wks_ziel.Range("A2:H500").Interior.Color = xlNone
lng_zeile_quelle = 19
lng_zeile_ziel = 2
With obj_wks_quelle
lng_letzte_zeile_quelle = .Cells(1048576, 2).End(xlUp).Row
Do Until lng_zeile_quelle > lng_letzte_zeile_quelle
If .Cells(lng_zeile_quelle, 1) = "" And .Cells(lng_zeile_quelle, 2)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Range("A" & lng_zeile_ziel & ":H" & lng_zeile_ziel).Interior.Color =  _
vbYellow  ' Farbe ggf. anpassen
lng_zeile_ziel = lng_zeile_ziel + 1
ElseIf .Cells(lng_zeile_quelle, 1)  "" And .Cells(lng_zeile_quelle, 2)  "" Then
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = "Kommentar"
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11)
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12)
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13)
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, lng_spalte)
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), _
.Cells(lng_zeile_quelle, 13))
If .Cells(lng_zeile_quelle, 13)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) & "-" & _
_
Format(WorksheetFunction.WeekNum(DateSerial(Year(.Cells(10,  _
lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13)), 1), " _
00")
End If
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_ziel = lng_zeile_ziel + 1
End If
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub
Gruß
Regina
AW: Makro gesucht
18.08.2019 12:23:32
Stephan
Hey Regina,
da ändert sich leider nichts.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6)" anwende, dann kommt 53 raus.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6;21" anwende, dann kommt 1 raus, was ja passen würde.
Wenn ich aber die Formel "Isokalenderwoche" verwende, dann kommt 1 raus, was ja passen würde.
Jetzt müsste nur noch das korrekt Jahr dazu, dann wäre es richtig.
Sorry für die Umstände ...
Beste Grüße
STephan
AW: Makro gesucht
18.08.2019 12:56:43
Stephan
Hey Regina,
da ändert sich leider nichts.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6)" anwende, dann kommt 53 raus.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6;21" anwende, dann kommt 1 raus, was ja passen würde.
Wenn ich aber die Formel "Isokalenderwoche" verwende, dann kommt 1 raus, was ja passen würde.
Jetzt müsste nur noch das korrekt Jahr dazu, dann wäre es richtig.
Sorry für die Umstände ...
Beste Grüße
STephan
AW: Makro gesucht
18.08.2019 13:34:49
Stephan
Hey Regina,
da ändert sich leider nichts.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6)" anwende, dann kommt 53 raus.
Wenn ich in Excel auf das Datum die Formel "Kalenderwoche(G6;21" anwende, dann kommt 1 raus, was ja passen würde.
Wenn ich aber die Formel "Isokalenderwoche" verwende, dann kommt 1 raus, was ja passen würde.
Jetzt müsste nur noch das korrekt Jahr dazu, dann wäre es richtig.
Sorry für die Umstände ...
Beste Grüße
STephan
AW: Makro gesucht
18.08.2019 15:02:07
Regina
ok, dann hier mit ISOKalenderwoche:
Option Explicit
Public Sub Uebertrag()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim lng_letzte_zeile_quelle As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
obj_wks_ziel.Range("A2:H500").ClearContents       ' Hier ggf. Zeilennummer erweitern
obj_wks_ziel.Range("A2:H500").Interior.Color = xlNone
lng_zeile_quelle = 19
lng_zeile_ziel = 2
With obj_wks_quelle
lng_letzte_zeile_quelle = .Cells(1048576, 2).End(xlUp).Row
Do Until lng_zeile_quelle > lng_letzte_zeile_quelle
If .Cells(lng_zeile_quelle, 1) = "" And .Cells(lng_zeile_quelle, 2)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Range("A" & lng_zeile_ziel & ":H" & lng_zeile_ziel).Interior.Color =  _
vbYellow  ' Farbe ggf. anpassen
lng_zeile_ziel = lng_zeile_ziel + 1
ElseIf .Cells(lng_zeile_quelle, 1)  "" And .Cells(lng_zeile_quelle, 2)  "" Then
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = "Kommentar"
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11)
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12)
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13)
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, lng_spalte)
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), _
.Cells(lng_zeile_quelle, 13))
If .Cells(lng_zeile_quelle, 13)  "" Then
If WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))) = 1  _
Then
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) _
+ 1 & "-" & _
Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10,  _
lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00") _
Else
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) & " _
-" & _
Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10,  _
lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00") _
End If
End If
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_ziel = lng_zeile_ziel + 1
End If
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub
Gruß
Regina
AW: Makro gesucht
18.08.2019 15:18:26
Regina
... da wra noch ein Denkfehler bzgl. der Jahreszahl drin. Hier korrigiert:
Option Explicit
Public Sub Uebertrag()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim lng_letzte_zeile_quelle As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
obj_wks_ziel.Range("A2:H500").ClearContents       ' Hier ggf. Zeilennummer erweitern
obj_wks_ziel.Range("A2:H500").Interior.Color = xlNone
lng_zeile_quelle = 19
lng_zeile_ziel = 2
With obj_wks_quelle
lng_letzte_zeile_quelle = .Cells(1048576, 2).End(xlUp).Row
Do Until lng_zeile_quelle > lng_letzte_zeile_quelle
If .Cells(lng_zeile_quelle, 1) = "" And .Cells(lng_zeile_quelle, 2)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Range("A" & lng_zeile_ziel & ":H" & lng_zeile_ziel).Interior.Color =  _
vbYellow  ' Farbe ggf. anpassen
lng_zeile_ziel = lng_zeile_ziel + 1
ElseIf .Cells(lng_zeile_quelle, 1)  "" And .Cells(lng_zeile_quelle, 2)  "" Then
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = "Kommentar"
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11)
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12)
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13)
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, lng_spalte)
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), _
.Cells(lng_zeile_quelle, 13))
If .Cells(lng_zeile_quelle, 13)  "" Then
If WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))) = 1 _
And Month(.Cells(10, lng_spalte)) = 12 Then
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) _
+ 1 & "-" & _
Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10,  _
lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00") _
Else
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = Year(.Cells(10, lng_spalte)) & " _
-" & _
Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10,  _
lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00") _
End If
End If
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_ziel = lng_zeile_ziel + 1
End If
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub

AW: Makro gesucht
19.08.2019 10:26:38
Stephan
Hallo Regina,
danke, jetzt passt es.
Werde diese Woche mit meinem Tool arbeiten. Wenn noch etwas auftaucht, darf ich mich dann nochmal melden?
Einstweilen beste Grüße
STephan
AW: Makro gesucht
19.08.2019 11:34:24
Regina
Klar
Gruß Regina
AW: Makro gesucht
19.08.2019 13:31:34
Stephan
Hey Regina,
habe noch einen Fehler bzgl. der KW gefunden:
Wendet man das Datum 05.01.2020 an, dann ist das immer noch die KW 1 im Jahr 2020.
Das Makro schreibt aber das Jahr 2021 hin (siehe gelb markierte Felder).
Ich kann den Fehler über eine Pivot zwar filtern, möchte händisches Eingreifen in der Tabelle aber vermeiden.
Vielleicht hast du noch eine Idee?
Anbei die Datei. Da ich den Code noch ein wenig angepasst habe, bitte mit dieser Version weitermachen.
https://www.herber.de/bbs/user/131504.xlsm
Danke schon mal vorab!
Beste Grüße
Stephan
AW: Makro gesucht
19.08.2019 17:29:06
Regina
Hi,
ich hatte zuletzt noch eine korrigierte Version gepostet, da mir der Fehler auch noch aufgefallen war. Hier nochmal eingearbeitet in deinen letzten Code:
Option Explicit
Public Sub Uebertrag_SBA_SBE()
Dim lng_zeile_quelle As Long
Dim lng_zeile_ziel As Long
Dim lng_spalte As Long
Dim lng_letzte_zeile_quelle As Long
Dim obj_wks_quelle As Worksheet
Dim obj_wks_ziel As Worksheet
Set obj_wks_quelle = Worksheets("Test")
Set obj_wks_ziel = Worksheets("Neu")
obj_wks_ziel.Range("A2:k5000").ClearContents       ' Hier ggf. Zeilennummer erweitern
obj_wks_ziel.Range("A2:k5000").Interior.Color = xlNone
lng_zeile_quelle = 19
lng_zeile_ziel = 2
With obj_wks_quelle
lng_letzte_zeile_quelle = .Cells(1048576, 2).End(xlUp).Row
Do Until lng_zeile_quelle > lng_letzte_zeile_quelle
If .Cells(lng_zeile_quelle, 1) = "" And .Cells(lng_zeile_quelle, 2)  "" Then
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2)
obj_wks_ziel.Range("A" & lng_zeile_ziel & ":K" & lng_zeile_ziel).Interior.Color =  _
vbYellow  ' Farbe ggf. anpassen
lng_zeile_ziel = lng_zeile_ziel + 1
ElseIf .Cells(lng_zeile_quelle, 1)  "" And .Cells(lng_zeile_quelle, 2)  "" Then
lng_spalte = 16
Do Until .Cells(lng_zeile_quelle, lng_spalte) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 1) = .Cells(lng_zeile_quelle, 2) 'Kostenart
obj_wks_ziel.Cells(lng_zeile_ziel, 2) = .Cells(lng_zeile_quelle, 4) 'Kommentar
obj_wks_ziel.Cells(lng_zeile_ziel, 3) = .Cells(lng_zeile_quelle, 11) 'Zuordnung
obj_wks_ziel.Cells(lng_zeile_ziel, 4) = .Cells(lng_zeile_quelle, 12) 'MWST-Satz
obj_wks_ziel.Cells(lng_zeile_ziel, 5) = .Cells(lng_zeile_quelle, 13) 'Fä _
lligkeit Tag
If .Cells(lng_zeile_quelle, 13) = "" Then obj_wks_ziel.Cells(lng_zeile_ziel, 5). _
Interior.Color = vbRed 'Farbliche Markierung, falls kein Fälligkeitstag eingetragen wurde
obj_wks_ziel.Cells(lng_zeile_ziel, 6) = .Cells(lng_zeile_quelle, lng_spalte) ' _
Umsatz netto
obj_wks_ziel.Cells(lng_zeile_ziel, 7) = .Cells(lng_zeile_quelle, lng_spalte) * ( _
1 + .Cells(lng_zeile_quelle, 12)) 'Umsatz brutto
obj_wks_ziel.Cells(lng_zeile_ziel, 8) = DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13)) 'Fälligkeit Datum
obj_wks_ziel.Cells(lng_zeile_ziel, 9) = Year(.Cells(10, lng_spalte)) & "-" &  _
Format(Month(.Cells(10, lng_spalte)), "00") 'Fälligkeit Monat
obj_wks_ziel.Cells(lng_zeile_ziel, 10) = DateSerial(Year(.Cells(10, lng_spalte)) _
, Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13)) 'Fälligkeit KW
If .Cells(lng_zeile_quelle, 13)  "" Then
If WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10, lng_spalte)), _
Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))) = 1  _
And Month(.Cells(10, lng_spalte)) = 12 Then
obj_wks_ziel.Cells(lng_zeile_ziel, 10) = Year(.Cells(10, lng_spalte) _
) + 1 & "-" & Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10, lng_spalte)), Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00") _
Else
obj_wks_ziel.Cells(lng_zeile_ziel, 10) = Year(.Cells(10, lng_spalte)) &  _
"-" & Format(WorksheetFunction.IsoWeekNum(DateSerial(Year(.Cells(10, lng_spalte)), Month(.Cells(10, lng_spalte)), .Cells(lng_zeile_quelle, 13))), "00")
End If
Else
obj_wks_ziel.Cells(lng_zeile_ziel, 10) = ""
obj_wks_ziel.Cells(lng_zeile_ziel, 10).Interior.Color = vbRed
End If
obj_wks_ziel.Cells(lng_zeile_ziel, 11) = obj_wks_ziel.Cells(lng_zeile_ziel, 3) & _
" " & obj_wks_ziel.Cells(lng_zeile_ziel, 10) 'Suchkriterium Zuordnung Liqui
lng_spalte = lng_spalte + 1
lng_zeile_ziel = lng_zeile_ziel + 1
Loop
lng_zeile_ziel = lng_zeile_ziel + 1
End If
lng_zeile_quelle = lng_zeile_quelle + 1
Loop
End With
End Sub
Gruß
Regina
AW: Makro gesucht
19.08.2019 18:06:55
Stephan
Hey Regina,
danke, jetzt sieht es gut aus.
Auch mit dem Beispiel 31.12.2018 (1. Tag der KW 1-2019) wird das richtige Ergebnis geliefert.
Nochmals besten Dank!
Herzliche Grüße
Stephan
AW: Makro gesucht
19.08.2019 18:54:03
Regina
... prima, freut mich.
Gruß und frohes Schaffen weiterhin
Regina

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige