Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1644to1648
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

Daten aus Masterdatei prüfen und kopieren

Daten aus Masterdatei prüfen und kopieren
16.09.2018 10:57:52
Andreas
Hallo liebe Forumer,
ich ein Neuling in der VBA Programmierung.
Nun stehe ich vor einem Problem. Ich muss für folgendes Szenario
ein Lösungsansatz finden:
Ich habe eine vorh. Masterdatei (.xlsx) die durch eine ext. Buchhaltersoftware monatlich exportiert wird. Nun möchte ich gerne aus dieser Masterdatei per VBA
kompremierte Werte in deine neue xlsx.Datei einlesen.
Es sollte in der Master folgendes geprüft werden. Steht in Zeile 3 der String "Kostenstelle", dann kopiere jeweils die Zeile 4 in neue Datei. In Zeile 4 steht
die Kostenstelle mit Beschreibung und in Klammern die Kostenstellennummer. Diese Kostenstellennummer müsste separat in einer Zelle geschrieben werden.
Als nächstes muss ich dann aus Spalte 3 (hier stehen die einzelnen Aufwandskonten) jeweils die Werte in Kontengruppen (z.B. 4000-4240) zusammenfassen und die Summe (€)
unter die Kostenstellen in der neuen Datei kopieren.
Vielleicht könnt Ihr mir helfen.
Ich möchte gerne auch verstehen wir Ihr so eine Aufgabe löst und umsetzt.
Dank vorab.
Gruß Andreas

71
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
16.09.2018 11:10:41
Rob
Hi Andreas,
hört sich lösbar an aber ne Datei zum herunterladen wäre gut!
LG
AW: Daten aus Masterdatei prüfen und kopieren
16.09.2018 11:49:24
Andreas
Hi Rob,
danke für deine Antwort.
An die richtige Masterdatei komme ich leider erst morgen wieder ran,
da diese auf meinem Arbeitsrechner liegt.
Ich könnte diese mal grob nachbauen wenn es reicht, ansonsten würde ich die
Master morgen posten.
Ok?
Danke Andreas
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 08:38:25
Andreas
Hallo zusammen,
ich habe jetzt mal die Masterdatei zu meinem Problem hochgeladen.
Vielleicht könnt Ihr mir ja helfen.
https://www.herber.de/bbs/user/124005.xlsx
Gruß
Andreas
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 09:49:32
Rob
Guten Morgen Andreas,
in der Masterdatei steht "Kostenstelle" aber in Zeile 2, nicht 3. Was ist richtig?
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 10:03:46
Rob
Noch zwei Fragen - der Saldo zum jeweiligen Konto steht dann in Spalte C? Diesen willst Du dann für z.B. Konto 4000-4999 aufsummieren?
In Deiner Tabelle sind zwei Kostenstellen; W-Bonn und W-Köln. Sollen die unterschiedlichen Kostenstellen nochmal irgendwie berücksichtigt werden?
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 10:26:12
Andreas
Hallo Rob,
"Kostenstelle" in Zeile 2 ist korrekt.
In Spalte C steht der gesamte Saldo aller Kostenstellen (Dieser soll nicht summiert werden). Die einzelnen Werte pro Kostenstelle werden dann aufgegliedert unter den Kostenstellen. Diese Daten benötige ich dann (gruppenweise)kumuliert nach Kostenstelle. D.h. Ich muss versch. Kontensummen je Kostenstelle zusammenfassen (4000-4400 / 8000-8200). Die Kostenstellen W-Bonn und W-Köln werden nach rechts fortgeführt falls neue dazu kommen. Er soll quasi überprüfen ob Kostenstellen vorhanden sind, danach
die Zelle darunter Zeile 3 kopieren, Die Kostenstellennnummer in Klammern in separater Zelle einfügen
und alle gruppenweise Summen darunter in die Zellen schreiben.
Hoffe es ist halbwegs verständlich.....?
Gruß
Andreas
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 11:36:46
Rob
Schau mal bitte zunächst, ob das so mit dem Aufbau der Tabelle1 in Ordnung geht:

Sub AuswertungKostenstellen()
Dim r, Row2 As Range
Dim FindKostenstelle As Range
Dim SearchCharacter As String
Dim LastColumn As Integer
SearchCharacter = "("
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
Set FindKostenstelle = Row2.Find("Kostenstelle")
If Not FindKostenstelle Is Nothing Then
For Each r In Row2
LastColumn = Tabelle1.Cells(1, Tabelle1.Columns.Count).End(xlToLeft).Column + 1
Tabelle1.Cells(1, LastColumn) = r.Offset(1, 0)
Tabelle1.Cells(1, LastColumn + 1) = Mid(Tabelle1.Cells(1, LastColumn), InStr(Tabelle1. _
Cells(1, LastColumn), SearchCharacter) + 1, 4)
Next r
Tabelle1.Columns("A").Delete
End If
End Sub
Anschließend kann man dann noch die Werte kumulieren.
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 11:49:19
Andreas
Hi Rob,
das sieht schon sehr gut aus.
3 Fragen hierzu:
1. Kann er die separierte Kostenstellennummer auch unter die Zeile schreiben statt rechts daneben?
2. Kann das einfügen der Kostenstellen ab Spalte D starten, statt Spalte A?
3. Ich möchte gerne die Auswertung mit einer neuen Arbeitsmappe machen, da die Masterdatei ja immer wieder neu generiert wird, sprich Masterdatei öffnen auslesen und in neue Datei komprimiert.xlxs auswerten.
Danke Andreas
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 14:10:24
Rob
Lässt sich auch untereinander darstellen:

Sub AuswertungKostenstellen()
Dim r, Row2 As Range
Dim FindKostenstelle As Range
Dim SearchCharacter As String
Dim LastColumn, LastRow As Integer
SearchCharacter = "("
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
Set FindKostenstelle = Row2.Find("Kostenstelle")
If Not FindKostenstelle Is Nothing Then
For Each r In Row2
LastColumn = Tabelle1.Cells(1, Tabelle1.Columns.Count).End(xlToLeft).Column + 1
Tabelle1.Cells(1, LastColumn) = r.Offset(1, 0)
LastRow = Tabelle1.Cells(Rows.Count, LastColumn).End(xlUp).Row + 1
Tabelle1.Cells(LastRow, LastColumn) = Mid(Tabelle1.Cells(1, LastColumn), InStr(Tabelle1. _
Cells(1, LastColumn), SearchCharacter) + 1, 4)
Next r
End If
Tabelle1.Range("A:B").EntireColumn.Insert
End Sub
Hier ein erster Entwurf für die kumulierten Zahlen:

Sub Kumulieren()
Dim r, Kontos As Range
Dim Sum0, Sum1, Sum2, Sum3, Sum4, Sum5, Sum6, Sum7, Sum8, Sum9 As Long
Dim LastRow As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
Dim GruppeKostenstelle0, GruppeKostenstelle1, GruppeKostenstelle2, GruppeKostenstelle3,  _
GruppeKostenstelle4, GruppeKostenstelle5, _
GruppeKostenstelle6, GruppeKostenstelle7, GruppeKostenstelle8, GruppeKostenstelle9 As Long
GruppeKostenstelle0 = 999
GruppeKostenstelle1 = 1999
GruppeKostenstelle2 = 2999
GruppeKostenstelle3 = 3999
GruppeKostenstelle4 = 4999
GruppeKostenstelle5 = 5999
GruppeKostenstelle6 = 6999
GruppeKostenstelle7 = 7999
GruppeKostenstelle8 = 8999
GruppeKostenstelle9 = 9999
For Each r In Kontos
Select Case r
Case Is 

Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 16:21:41
Andreas
Hi Rob,
das funktioniert soweit, jedoch nur bei der ersten Kostenstelle, danach bleibt alles leer.
Wie oder wo kann ich mir genau die Gruppen selbst festlegen, da diese nicht immer
in Reihe (1000-1999) sind, sondern auch (z.B. Kto 1000/4000) oder teilweise Konto nicht mit in die
Summierung einfliessen.
Danke für deine Mühen
Gruß Andreas
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 16:44:22
Rob
Für die zweite Kostenstelle muss ich es noch anpassen.
Du kannst die Gruppen hier anpassen:

GruppeKostenstelle0 = 999
GruppeKostenstelle1 = 1999
GruppeKostenstelle2 = 2999
GruppeKostenstelle3 = 3999
GruppeKostenstelle4 = 4999
GruppeKostenstelle5 = 5999
GruppeKostenstelle6 = 6999
GruppeKostenstelle7 = 7999
GruppeKostenstelle8 = 8999
GruppeKostenstelle9 = 9999

Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 17:00:47
Andreas
Ah. ok. Danke.
Könntest du das so anpassen, dass es auch für mehr als 2 Kostenstellen funktioniert?
IM Beispiel sind es nur 2, tatsächlich min. 30 und fortlaufen.
DANKE
AW: Daten aus Masterdatei prüfen und kopieren
17.09.2018 18:28:34
Rob
Probier es mal damit:

Option Explicit
Sub Kumulieren()
Dim r, Kontos As Range
Dim Sum0, Sum1, Sum2, Sum3, Sum4, Sum5, Sum6, Sum7, Sum8, Sum9 As Long
Dim LastRow, CountColumns, i As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
CountColumns = Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
Dim GruppeKostenstelle0, GruppeKostenstelle1, GruppeKostenstelle2, GruppeKostenstelle3,  _
GruppeKostenstelle4, GruppeKostenstelle5, _
GruppeKostenstelle6, GruppeKostenstelle7, GruppeKostenstelle8, GruppeKostenstelle9 As Integer
GruppeKostenstelle0 = 999
GruppeKostenstelle1 = 1999
GruppeKostenstelle2 = 2999
GruppeKostenstelle3 = 3999
GruppeKostenstelle4 = 4999
GruppeKostenstelle5 = 5999
GruppeKostenstelle6 = 6999
GruppeKostenstelle7 = 7999
GruppeKostenstelle8 = 8999
GruppeKostenstelle9 = 9999
For i = 3 To CountColumns - 1
For Each r In Kontos
Select Case r
Case Is 

Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 08:53:05
Rob
Ich habe den Code nochmal verschlankt. Konstanten anstelle von Variablen für die Kostenstellen und Arrays für die Summen:

Sub Kumulieren2()
Dim r, Kontos As Range
Dim sum(0 To 9)
Dim LastRow, CountColumns, i, x As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
CountColumns = Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
Const GruppeKostenstelle0 = 999
Const GruppeKostenstelle1 = 1999
Const GruppeKostenstelle2 = 2999
Const GruppeKostenstelle3 = 3999
Const GruppeKostenstelle4 = 4999
Const GruppeKostenstelle5 = 5999
Const GruppeKostenstelle6 = 6999
Const GruppeKostenstelle7 = 7999
Const GruppeKostenstelle8 = 8999
Const GruppeKostenstelle9 = 9999
For i = 3 To CountColumns - 1
For Each r In Kontos
Select Case r
Case Is 

Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 09:40:05
Andreas
Das sieht top aus und scheint zu funktionieren.
Bitte erlaube mir noch 3 kleine Fragen:
1. Kannst du mir mal ein Beispiel geben wie ich die Kostengruppen anpasse. z.B. mit drei einzelnen Konto die nicht untereinander stehen.
2. Wie kann ich die Werte Sub_kumlieren direkt als Euro-Werte übernehmen?
3. Die Auswertungen funktionieren innerhalb des Workbooks. Wie realisiere ich das, wenn ich die Auswertung aus einem anderen Workbook heraus starten und auswerten möchte, da die Masterdatei ja immer wieder neu generiert wird und das Makro dann weg ist.
DANKE für deine Hilfe
Gruß Andreas
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 11:06:05
Rob
Zu 1: Verstehe nicht, wie Du das meinst.
Zu 2: Ganz am Schluß (vor End Sub) einfügen:

Tabelle1.Range("D3", Tabelle1.Range("D3").End(xlDown).End(xlToRight)).Style = "Currency"

Füge auch noch folgende Codezeilen hinzu (am besten direkt nach den Konstanten Const GruppeKostenstelle0 etc.), damit Du keine Leerzeilen in der ersten Spalte hast:

'Variablen den Wert 0 zuweisen
For x = LBound(sum) To UBound(sum)
sum(x) = 0
Next x

Zu 3: Entwicklertools/Makro aufzeichnen/Makro speichern in: Persönliche Makroarbeitsmappe/OK und anschließend die Aufzeichnung direkt beenden. Jetzt hast du im VBA-Editor eine persönliche Arbeitsmappe (PERSONAL.XLSB).
Anzeige
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 11:19:54
Andreas
Klasse. Danke
zu 1: Ich habe ca. 108 Konten. Hier ein Ausschnitt:
3407
3409
3411
3412
3413
3417
3733
3736
4100
4110
4111
4112
4113
4114
Jetzt möchte ich mir die Konten in Gruppen zusammenstellen. Wie z.B. die drei fett markierten.
Aktuell nehmen wir ja die Konten von 0-999, 1000-1999 etc.. Gerne möchte ich aber wie oben erwähnt einzelnen Konten zuweisen. Z.B. Summe der fett markierten Konten.
DANKE
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 13:03:18
Rob
Zu 1: Du musst dann ein Array für jede Kostenstelle erstellen und anschl. dem Array die Konten zuweisen:

'Array für Kostenstelle0 erstellen
Dim ArrayGruppeKostenstelle0(1 To 3)
'Konten Kostenstelle0 zuweisen
ArrayGruppeKostenstelle0(1) = 3407
ArrayGruppeKostenstelle0(2) = 3736
ArrayGruppeKostenstelle0(3) = 4112
Die Select Case Anweisung musst Du dann für die jeweilige Gruppe wie folgt ändern:

Case ArrayGruppeKostenstelle0(1), ArrayGruppeKostenstelle0(2), ArrayGruppeKostenstelle0(3)
sum(0) = sum(0) + r.Offset(0, i)

Die Konstanten kannst Du dann herausnehmen.
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 14:24:24
Rob
Du könntest aber auch eine Enumeration erstellen (vor der Sub):
Option Explicit
Enum GruppeKostenstelle0
Konto1 = 3407
Konto2 = 3736
Konto3 = 4112
End Enum
Select Case dann wie folgt:
Case GruppeKostenstelle0.Konto1, GruppeKostenstelle0.Konto2, GruppeKostenstelle0.Konto3
sum(0) = sum(0) + r.Offset(0, i)

AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 17:18:27
Andreas
Super. Danke. Dann kämpfe ich mich hier mal durch und teste es aus.
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 18:16:27
Andreas
Eine Frage noch zu den Enummerationen z.B. GruppeKostenstelle0.
Ich habe 5 Kostengruppen, die betraglich zusammengefasst und ab Spalte D ausgewiesen werden.
Kann ich in Spalte C jeweils vor der Kostengruppe eigene Namen einfügen z.b. für Gruppe 0 = "Lohn"
und Gruppe 1 = Material?
DANKE vorab.
Dann nerve ich auch nicht mehr :o)
Gruß Andreas
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 20:43:34
Rob
Ja, in Spalte C kannst du beliebige Einträge vornehmen. Willst Du das manuell machen oder auch über's Makro?
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 08:08:38
Andreas
Morgen Rob,
das würde ich gerne über das Makro erledigen.
Gruß
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 08:46:25
Rob
Hierzu einfach die Zelle auswählen und den gewünschten Text zuweisen:

With Tabelle1
.Range("C3") = "Gruppe1"
.Range("C4") = "Gruppe2"
End With
Kannst Du dann am Schluß vor End Sub einfügen.
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 10:21:25
Andreas
Hallo Rob,
irgendwie funktioniert das mit dem Personalmakro nicht, oder ich verstehe das nicht (was wahrscheinlicher ist).
Ich habe die Enummerationen und die 2 Sub (Auswertung KOstenstellen / Kumulieren.
Diese möchte ich so speichern, dass das Personalmakro alles ausführt.
Wie gehe ich hier genau vor. Were nicht ganz schlau daraus.
DANKE Andreas
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 10:43:50
Rob
Du musst aus dem ersten Modul die Endung

END SUB
herausnehmen und aus dem zweiten die Eröffnung

SUB KUMULIEREN()
, damit es als ein Modul ausgeführt wird ODER Du kannst mit

Call Kumulieren
das zweite Modul aus dem ersten heraus starten -> vor

End Sub
einfügen.
Poste mal den ganzen Code wenn es trotzdem nicht klappt.
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 10:55:51
Andreas
Ok. Ich habe jetzt das mit dem Call Kumulieren verwendet, da er bei der ersten Lösung meckert, da die Variable r doppelt vergeben ist.
Aber was mache ich genau um das jetzt als mein PErsonalmakro zu speichern, das habe ich nicht hinbekommen.
PS: Wie kann ich die Summe in fett anzeigen lassen?
DANKE
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 12:02:00
Rob
Hi,
Du musst in Deiner Personal.xlsb einfach ein Modul, bzw. zwei Module einfügen und dort alles reinkopieren.
Wegen Summe in Fett habe ich Dir bereits geantwortet.
Grüße
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 12:21:00
Andreas
Danke. Habe ich gemacht. Jedoch meckert er, das die keine Variable definiert ist bei Tabelle2
bei SetRow2 (s. unten)
Sub AuswertungKostenstellen()
Dim r, Row2 As Range
Dim FindKostenstelle As Range
Dim SearchCharacter As String
Dim LastColumn, LastRow As Integer
SearchCharacter = "(1"
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 12:44:12
Rob
Du musst die 1 bei der Zuweisung der Variablen SearchCharacter herausnehmen:
SearchCharacter = "("

AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 12:52:06
Andreas
Ach Mist. Das wäre schlecht, da ich bei den Kostenstellen teilsweise nicht nur die Nummer in
Klammern stehen habe, sondern auch in separaten Klammern ein Text.
Wie fange ich das ab?
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 18:58:20
Andreas
Muss leider doch nochmal. Ich möchte gerne noch in Zeile 8 eine Aufsummierung der Summen Zeile 3-7,
falls in Zeile 1 und 2 Kostenstellen enthalten sind .
Danke
AW: Daten aus Masterdatei prüfen und kopieren
18.09.2018 21:37:52
Rob
Vor End Sub einfügen:

If IsEmpty(Range("D1")) = False Then
For i = 4 To CountColumns
Cells(8, i).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
Next i
End If

AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 08:14:45
Andreas
So, nun aber die letzte Frage vorerst.
Wie bekomme ich die Summe in Fettschrift dargestellt?
DANKE
AW: Daten aus Masterdatei prüfen und kopieren
19.09.2018 08:42:29
Rob

Tabelle1.Range("D8", Range("D8").End(xlToRight)).Font.Bold = True
PS: Die For Next Schleife für die Summen übrigens vor die Euro-Formatierung einfügen. Ansonsten werden die Summen nicht in Euro formatiert.
Du kannst die Schleife für die Summen übrigens auch um folgende Codezeile ergänzen - dann werden die Summen sofort FETT formatiert:

'Summen der Kostenstellen erstellen
If IsEmpty(Range("D1")) = False Then
For i = 4 To CountColumns
Cells(8, i).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
Cells(8, i).Font.Bold = True
Next i
End If
'Euro-Format
Tabelle1.Range("D3", Tabelle1.Range("D3").End(xlDown).End(xlToRight)).Style = "Currency"
'Summen in Fett -> entfällt, da in For/Next Schleife für Summen eingebunden
'Tabelle1.Range("D8", Range("D8").End(xlToRight)).Font.Bold = True
End Sub

Bitte hier weitermachen! Danke!
19.09.2018 14:58:46
lupo1
Bitte hier weitermachen! Danke!
19.09.2018 15:04:29
lupo1
AW: Bitte hier weitermachen! Danke!
19.09.2018 15:19:40
Rob
Hallo Andreas,
zu Deiner letzten Frage:
Ach Mist. Das wäre schlecht, da ich bei den Kostenstellen teilsweise nicht nur die Nummer in
Klammern stehen habe, sondern auch in separaten Klammern ein Text.
Wie fange ich das ab?
Wie sieht der Inhalt der Zelle mit der zweiten Klammern aus? Hat er eine gleichbleibende Struktur? Der Text soll dann direkt neben der Kostenstelle in Tabelle1 stehen?
AW: Bitte hier weitermachen! Danke!
19.09.2018 15:40:03
Andreas
Hallo Rob,
Es handelt sich immer um einen String, ausser die Kostenstelle ist nummerisch.
Nur diese sollte auch wie schon geschehen untendrunter ausgelesen werden.
Suchen wir nur nach "(" übernimmt er den Text der zum Teil in separaten Klammern steht.
Beispiel: Standard: "W-Bonn, Neubau Lager RAL (1601)"
oder "W-Rhein-Palais, Bonner Bogen (Hohr-Gruppe) (1603)". Hier liest er die erste KLammer bei der Kostenstelle aus, also "Hohr". Das müssten wir irgendwie abfangen.
AW: Bitte hier weitermachen! Danke!
19.09.2018 15:56:14
Rob
Also wenn die Kostenstellen immer am Schluss der Zelle stehen, geht das relativ einfach:
Im ersten Modul die for each Schleife wie folgt ändern:

If Not FindKostenstelle Is Nothing Then
For Each r In Row2
LastColumn = Tabelle1.Cells(1, Tabelle1.Columns.Count).End(xlToLeft).Column + 1
Tabelle1.Cells(1, LastColumn) = r.Offset(1, 0)
Tabelle1.Cells(2, LastColumn) = Left(Right(Tabelle1.Cells(1, LastColumn), 5), 4)
Next r
End If

AW: Bitte hier weitermachen! Danke!
19.09.2018 16:15:24
Andreas
WELTKLASSE !! DANKE DANKE DANKE
Ist es auch möglich das sich die Spalten nach dem Import selbst auf die richtige Größe setzen?
AW: Bitte hier weitermachen! Danke!
19.09.2018 17:14:44
Rob

Tabelle1.Cells.EntireColumn.AutoFit
Wir kommen langsam zum Ziel, habe ich das Gefühl. :-)
PS: Solche Formatierungen kannst Du relativ einfach über den Makrorekorder in Erfahrung bringen. Ggf. musst Du nur noch die Range dynamisch anpassen.
AW: Bitte hier weitermachen! Danke!
20.09.2018 08:49:08
Andreas
Hi Rob,
so jetzt passt soweit alles bis auf das Personalmakro. Habe alles reinkopiert.
Er meckert bei
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
da er die Tabelle 2 nicht findet. Die ist auch im Personalmakro nicht mit drin.
Wie bekomme ich diese da noch rein?
DANKE
AW: Bitte hier weitermachen! Danke!
20.09.2018 10:15:29
Rob
Tabelle2 steht für das zweite Arbeitsblatt. Wenn es kein zweites Arbeitsblatt im Workbook gibt, dann meckert er natürlich. Folgende Codezeile hinzufügen:
ActiveWorkbook.Worksheets.Add After:=Tabelle1
Ich bin allerdings davon ausgegangen, dass die Daten mit den Kostenstellen/Konten etc. in Tabelle2 eingetragen sind und diese in Tabelle1 kumuliert werden sollen. Wenn das nicht der Fall ist, musst Du Tabelle1 mit Tabelle2 in den Modulen austauschen.
Vllt noch etwas zum Verständnis von den persönlichen Makroarbeitsmappe: Du kannst die dort enthaltenen Module von jedem Workbook aus ausführen. Du musst hier kein zusätzliches Arbeitsblatt bzw. Worksheet bzw. Tabelle hinzufügen.
AW: Bitte hier weitermachen! Danke!
20.09.2018 10:32:31
Andreas
Danke. Aber es gibt ein 2tes Arbeitsblatt in der Masterdatei. Diese wird exportiert und legt dann Tabelle1 als leer an und Tabelle2 mit den exportierten Daten. In Tabelle 1 werden diese kumuliert.
Das Makro im Arbeitsblatt selbst geht. Kopiere ich dieses Makro in das Personal meckert er wie gesagt.
AW: Bitte hier weitermachen! Danke!
20.09.2018 11:00:53
Rob
Ups, habe vergessen, dass Du Dich in diesem Fall natürlich noch auf das Aktive Workbook beziehen musst. Füge ganz am Anfang - nach Sub DeinVergebenerName() ein:
With ActiveWorkbook
Und vor End Sub:
End with

AW: Bitte hier weitermachen! Danke!
20.09.2018 11:28:18
Andreas
Wo füge ich das genau ein?
Option Explicit
Enum GruppeKostenstelleLohn
Konto1 = 4100
Konto2 = 4110
Konto3 = 4111
Konto4 = 4112
Konto5 = 4113
Konto6 = 4114
Konto7 = 4115
Konto8 = 4116
Konto9 = 4117
Konto10 = 4120
Konto11 = 4130
Konto12 = 4131
Konto13 = 4138
Konto14 = 4140
Konto15 = 4161
Konto16 = 4165
Konto17 = 4170
Konto18 = 4174
Konto19 = 4176
Konto20 = 4190
Konto21 = 4198
Konto22 = 4199
End Enum
Enum GruppeKostenstelleMaterial
Konto1 = 3400
Konto2 = 3401
Konto3 = 3402
Konto4 = 3403
Konto5 = 3404
Konto6 = 3405
Konto7 = 3406
Konto8 = 3407
Konto9 = 3409
Konto10 = 3411
Konto11 = 3412
Konto12 = 3413
Konto13 = 3417
End Enum
Enum GruppeKostenstelleFremd
Konto1 = 4570
Konto2 = 4902
End Enum
Enum GruppeKostenstelleSubunt
Konto1 = 3120
Konto2 = 4780
End Enum
Enum GruppeKostenstelleRest
Konto1 = 485
Konto2 = 2020
Konto3 = 2110
Konto4 = 2115
Konto5 = 2120
Konto6 = 2375
Konto7 = 2380
Konto8 = 2650
Konto9 = 2680
Konto10 = 2742
Konto11 = 3300
Konto12 = 3733
Konto13 = 3736
Konto14 = 4210
Konto15 = 4240
Konto16 = 4241
Konto17 = 4250
Konto18 = 4260
Konto19 = 4360
Konto20 = 4361
Konto21 = 4380
Konto22 = 4400
Konto23 = 4510
Konto24 = 4520
Konto25 = 4535
Konto26 = 4536
Konto27 = 4540
Konto28 = 4541
Konto29 = 4550
Konto30 = 4580
Konto31 = 4610
Konto32 = 4630
Konto33 = 4635
Konto34 = 4650
Konto35 = 4651
Konto36 = 4652
Konto37 = 4800
Konto38 = 4801
Konto39 = 4806
Konto40 = 4810
Konto41 = 4821
Konto42 = 4822
Konto43 = 4823
Konto44 = 4824
Konto45 = 4830
Konto46 = 4901
Konto47 = 4903
Konto48 = 4904
Konto49 = 4910
Konto50 = 4920
Konto51 = 4930
Konto52 = 4940
Konto53 = 4950
Konto54 = 4957
Konto55 = 4960
Konto56 = 4961
Konto57 = 4969
Konto58 = 4970
Konto59 = 4980
Konto60 = 8736
Konto61 = 8741
End Enum
Sub AuswertungKostenstellen()
Dim r, Row2 As Range
Dim FindKostenstelle As Range
Dim SearchCharacter As String
Dim LastColumn, LastRow As Integer
SearchCharacter = "("
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
Set FindKostenstelle = Row2.Find("Kostenstelle")
If Not FindKostenstelle Is Nothing Then
For Each r In Row2
LastColumn = Tabelle1.Cells(1, Tabelle1.Columns.Count).End(xlToLeft).Column + 1
Tabelle1.Cells(1, LastColumn) = r.Offset(1, 0)
Tabelle1.Cells(2, LastColumn) = Left(Right(Tabelle1.Cells(1, LastColumn), 5), 4)
Next r
End If
Tabelle1.Range("A:B").EntireColumn.Insert
Call Kumulieren2
End Sub

Sub Kumulieren2()
Dim r, Kontos As Range
Dim sum(0 To 4)
Dim LastRow, CountColumns, i, x As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
CountColumns = Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
'Const GruppeKostenstelle0 = 999
'Const GruppeKostenstelle1 = 1999
'Const GruppeKostenstelle2 = 2999
'Const GruppeKostenstelle3 = 3999
'Const GruppeKostenstelle4 = 4999
'Const GruppeKostenstelle5 = 5999
'Const GruppeKostenstelle6 = 6999
'Const GruppeKostenstelle7 = 7999
'Const GruppeKostenstelle8 = 8999
'Const GruppeKostenstelle9 = 9999
'Variablen den Wert 0 zuweisen
For x = LBound(sum) To UBound(sum)
sum(x) = 0
Next x
For i = 3 To CountColumns - 1
For Each r In Kontos
Select Case r
'Case Is 

AW: Bitte hier weitermachen! Danke!
20.09.2018 12:58:51
Rob
In Sub Kumulieren2() anstelle der Konstanten Const
AW: Bitte hier weitermachen! Danke!
20.09.2018 13:09:41
Rob
Sowas

Tabelle1.Range("C3").Value = "Lohnkosten:"
Tabelle1.Range("C3").Font.Bold = True
Tabelle1.Range("C3").Interior.Color = RGB(217, 217, 217)
kannst Du auch eleganter zusammenfassen:

With Tabelle1.Range("C3")
.Value = "Lohnkosten:"
.Font.Bold = True
.Interior.Color = RGB(217, 217, 217)
End with
Damit sparst Dir auch das Tippen. :-)
AW: Bitte hier weitermachen! Danke!
20.09.2018 13:55:00
Andreas
Verstehe ich jetzt nicht so ganz, anstelle welcher Konstanzen ? Die Const habe ich auskommentiert?
HILLLFFFEEEE :o)
Ich habe es hier eingefügt:
Sub Kumulieren2()
With ActiveWorkbook
Dim r, Kontos As Range
Dim sum(0 To 4)
Dim LastRow, CountColumns, i, x As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
CountColumns = Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
'Const GruppeKostenstelle0 = 999
Was mir etwas komisch vorkommt ist, dass er oben bei der Sub AuswertungKostenstellen()
die Tabelle2 scheinbar erkennt.
AW: Bitte hier weitermachen! Danke!
20.09.2018 14:42:35
Rob
Ja, bei den auskommentieren Konstanten einfügen.
With Active Workbook/End with in die Sub AuswertungKostenstellen() einfügen, weil er die Sub Kumulieren2 innerhalb dieses Moduls abruft.
Warum er die Tabelle2 jetzt erkennt, ist eine gute Frage?!? Funktioniert es denn jetzt?
AW: Bitte hier weitermachen! Danke!
20.09.2018 15:10:16
Andreas
Es funktioniert leider nicht. Er erkennt bei beiden Subs die Tabelle 2 nicht im PErsonalmakro.
Kann es daran liegen, dass das Tabellenblatt 2 nicht Tabelle2, sondern "Auswertung Kostenstellen"
heißt?
Hier der aktuelle Code:
Option Explicit
Enum GruppeKostenstelleLohn
Konto1 = 4100
Konto2 = 4110
Konto3 = 4111
Konto4 = 4112
Konto5 = 4113
Konto6 = 4114
Konto7 = 4115
Konto8 = 4116
Konto9 = 4117
Konto10 = 4120
Konto11 = 4130
Konto12 = 4131
Konto13 = 4138
Konto14 = 4140
Konto15 = 4161
Konto16 = 4165
Konto17 = 4170
Konto18 = 4174
Konto19 = 4176
Konto20 = 4190
Konto21 = 4198
Konto22 = 4199
End Enum
Enum GruppeKostenstelleMaterial
Konto1 = 3400
Konto2 = 3401
Konto3 = 3402
Konto4 = 3403
Konto5 = 3404
Konto6 = 3405
Konto7 = 3406
Konto8 = 3407
Konto9 = 3409
Konto10 = 3411
Konto11 = 3412
Konto12 = 3413
Konto13 = 3417
End Enum
Enum GruppeKostenstelleFremd
Konto1 = 4570
Konto2 = 4902
End Enum
Enum GruppeKostenstelleSubunt
Konto1 = 3120
Konto2 = 4780
End Enum
Enum GruppeKostenstelleRest
Konto1 = 485
Konto2 = 2020
Konto3 = 2110
Konto4 = 2115
Konto5 = 2120
Konto6 = 2375
Konto7 = 2380
Konto8 = 2650
Konto9 = 2680
Konto10 = 2742
Konto11 = 3300
Konto12 = 3733
Konto13 = 3736
Konto14 = 4210
Konto15 = 4240
Konto16 = 4241
Konto17 = 4250
Konto18 = 4260
Konto19 = 4360
Konto20 = 4361
Konto21 = 4380
Konto22 = 4400
Konto23 = 4510
Konto24 = 4520
Konto25 = 4535
Konto26 = 4536
Konto27 = 4540
Konto28 = 4541
Konto29 = 4550
Konto30 = 4580
Konto31 = 4610
Konto32 = 4630
Konto33 = 4635
Konto34 = 4650
Konto35 = 4651
Konto36 = 4652
Konto37 = 4800
Konto38 = 4801
Konto39 = 4806
Konto40 = 4810
Konto41 = 4821
Konto42 = 4822
Konto43 = 4823
Konto44 = 4824
Konto45 = 4830
Konto46 = 4901
Konto47 = 4903
Konto48 = 4904
Konto49 = 4910
Konto50 = 4920
Konto51 = 4930
Konto52 = 4940
Konto53 = 4950
Konto54 = 4957
Konto55 = 4960
Konto56 = 4961
Konto57 = 4969
Konto58 = 4970
Konto59 = 4980
Konto60 = 8736
Konto61 = 8741
End Enum
Sub AuswertungKostenstellen()
With ActiveWorkbook
Dim r, Row2 As Range
Dim FindKostenstelle As Range
Dim SearchCharacter As String
Dim LastColumn, LastRow As Integer
SearchCharacter = "("
Set Row2 = Tabelle2.Range("E2", Tabelle2.Range("E2").End(xlToRight))
Set FindKostenstelle = Row2.Find("Kostenstelle")
If Not FindKostenstelle Is Nothing Then
For Each r In Row2
LastColumn = Tabelle1.Cells(1, Tabelle1.Columns.Count).End(xlToLeft).Column + 1
Tabelle1.Cells(1, LastColumn) = r.Offset(1, 0)
Tabelle1.Cells(2, LastColumn) = Left(Right(Tabelle1.Cells(1, LastColumn), 5), 4)
Next r
End If
Tabelle1.Range("A:B").EntireColumn.Insert
Call Kumulieren2
End With
End Sub

Sub Kumulieren2()
Dim r, Kontos As Range
Dim sum(0 To 4)
Dim LastRow, CountColumns, i, x As Integer
Set Kontos = Tabelle2.Range("B4", Tabelle2.Range("B4").End(xlDown))
CountColumns = Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
ActiveWorkbook.Worksheets.Add After:=Tabelle1
'Const GruppeKostenstelle0 = 999
'Const GruppeKostenstelle1 = 1999
'Const GruppeKostenstelle2 = 2999
'Const GruppeKostenstelle3 = 3999
'Const GruppeKostenstelle4 = 4999
'Const GruppeKostenstelle5 = 5999
'Const GruppeKostenstelle6 = 6999
'Const GruppeKostenstelle7 = 7999
'Const GruppeKostenstelle8 = 8999
'Const GruppeKostenstelle9 = 9999
'Variablen den Wert 0 zuweisen
For x = LBound(sum) To UBound(sum)
sum(x) = 0
Next x
For i = 3 To CountColumns - 1
For Each r In Kontos
Select Case r
'Case Is 

AW: Bitte hier weitermachen! Danke!
20.09.2018 15:42:58
Rob
Wenn Du die Tabelle im Eigenschaften-Fenster nicht umbenannt hast, dann muss es funktionieren. Im Projekt-Fenster oben links sollte es wie folgt aussehen: Tabelle2(Auwertung Kostenstellen)
Ansonsten ersetze mal Tabelle2 mit Sheets(2) oder Sheets("Auswertung Kostenstellen")
AW: Bitte hier weitermachen! Danke!
20.09.2018 15:49:33
Andreas
Ich habe nichts geändert. Aber im Personalmakro taucht nur Tabelle1 auf.
Ich lade mal einen Screenshot hoch.
Userbild
AW: Bitte hier weitermachen! Danke!
20.09.2018 16:03:27
Rob
Ich glaube, wir müssen dass Workbook Bewertung_August direkt ansprechen. ActiveWorkbook funktioniert wohl nicht. Versuch es mal so:

Dim BewertungMonat as String
BewertungMonat = Dir("C:\HierSpeicherpfadeingeben\Bewertung*")
Workbooks(Bewertung).Activate
With Active Workbook und End With wieder herausnehmen. Den Code oben direkt nach Sub AuswertungKostenstellen() einfügen.
AW: Bitte hier weitermachen! Danke!
20.09.2018 16:17:43
Andreas
Das ist jetzt mein Speicherpfad: muss der * am Ende bleiben oder muss Bewertung_August dahin?
BewertungMonat = Dir("C:\Users\A.Harzer\Desktop\Bewertung\Bewertung*")
Fehler bei:
Workbooks(Bewertung).Activate Variable Bewertung nicht definiert
AW: Bitte hier weitermachen! Danke!
20.09.2018 17:06:27
Rob
Die Variable heißt BewertungMonat, Du hast nur Bewertung geschrieben.

Workbooks(BewertungMonat).Activate

AW: Bitte hier weitermachen! Danke!
20.09.2018 17:35:15
Andreas
Ok. Habe ich geändert. Leider hängt er sich immernoch an Tabelle2 auf. Nicht definiert.....
AW: Bitte hier weitermachen! Danke!
20.09.2018 18:55:09
Rob
Hast Du es mal mit den anderen Bezeichnungen probiert? Also z.b. Sheets(2)? Mit Strg+F kannst Du das relativ einfach austauschen.
AW: Bitte hier weitermachen! Danke!
20.09.2018 19:04:26
Rob
Vergiss das mit den anderen Bezeichungen Sheets(2) anstelle Tabelle2 etc. Du musst für jede Sub ein Modul in Personal.xlsb einfügen und von dort aus ausführen. Ich gehe mal von aus, dass Du die erste Sub vom Arbeitsblatt in Personal.xlsb ausausführst.
AW: Bitte hier weitermachen! Danke!
21.09.2018 09:21:44
Andreas
Hi Rob,
es klappt leider nicht. Er hat immernoch die Probleme mit der Tabelle2.
Die wird auch in der Personal.xlsb nicht angezeigt.
AW: Bitte hier weitermachen! Danke!
21.09.2018 10:14:23
Rob
Hi Andreas,
lade mal bitte eine Beispieldatei mit den beiden fertigen Modulen hoch. Ich versuche es dann nochmal direkt auf meinem Rechner - aus der Distanz ist das schwer zu sagen.
Grüsse
AW: Bitte hier weitermachen! Danke!
21.09.2018 10:37:46
Rob
Woran es noch liegen könnte: Du darfst die Module nicht direkt über Personal.xlsb ausführen. Du musst die Bewertungs-Datei öffnen und von dieser geöffneten Datei aus das Modul z.B. mit Alt+F8 starten.
Oder wir fügen noch Codezeilen hinzu, damit die Bewertungs-Datei geöffnet wird. Das wäre auch möglich.
AW: Bitte hier weitermachen! Danke!
21.09.2018 10:52:20
Andreas
Ich habe die Bewertungsdatei immer offen beim ausführen.
Leider kann ich dir die Datei nicht hochladen. Die hat 16 MB, gezippt immernoch 9 MB.
Reicht dir es, wenn ich 2 Dateien hochlade. Die Ursprungsexceldatei und eine Texteditordatei mit dem Code für das Modul?
DANKE
AW: Bitte hier weitermachen! Danke!
21.09.2018 10:53:35
Rob
ja das reicht
AW: Bitte hier weitermachen! Danke!
21.09.2018 11:34:09
Rob
Also Du musst tatsächlich alle Tabelle1 mit Sheets(1) und Tabelle2 mit Sheets(2) ersetzen -> Strg + F im Modul und alle ersetzen.
Zudem die letzte und vorletzte Zeile in der Sub Kumulieren ausmarkieren, sonst funktioniert der Autofit nicht + Summen werden fehlerhaft angezeigt.
'Columns("A:Z").Select
'Range(Selection, Selection.End(xlToRight)).Select

AW: Bitte hier weitermachen! Danke!
21.09.2018 12:45:41
Andreas
DANKE.
Jetzt klappt es fast. Was er aber jetzt nicht mehr macht ist die Aufsummierung und das Autofit
in der Personal.xlsb wenn ich eine neue Exportdatei damit bearbeite. Ich glaube da müssen wir noch in folgendem Absatz "Sheets(1)" einfügen, oder.`?
Und wenn wo? Alles andere klappt :o)
If IsEmpty(Range("D1")) = False Then
For i = 4 To CountColumns
Cells(8, i).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
Cells(8, i).Font.Bold = True
Cells(8, i).Interior.Color = RGB(255, 242, 204)
Cells(1, i).Font.Bold = True
Cells(2, i).Font.Bold = True
Cells(1, i).Interior.Color = RGB(185, 249, 188)
Cells(2, i).Interior.Color = RGB(185, 249, 188)
Next i
End If
AW: Bitte hier weitermachen! Danke!
21.09.2018 13:34:35
Rob
Hast Du die beiden letzten Zeilen in der Sub Kumulieren auskommentiert? Bei mir haben die Summen und Autofit anschl. funktioniert.
'Columns("A:Z").Select
'Range(Selection, Selection.End(xlToRight)).Select

AW: Bitte hier weitermachen! Danke!
21.09.2018 14:43:33
Andreas
Klappt......!!!!
DAAAAAAAANNNNNNNNNNNKKKKKKKKKKKKEEEEEEE
Ich denke nächste Woche kommt noch mal die ein oder andere Frage :o)
Aber das funtkioniert.
AW: Bitte hier weitermachen! Danke!
21.09.2018 15:24:54
Rob
Na endlich! :-)

303 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige