Zusammenführen von Datenblättern in externe Datei

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim Wb As Workbook For Each Wb In Workbooks If Wb.Name = "ÜbersichtsMappe" & ".xls" Then MsgBox "Die Datei ÜbersichtsMappe kann nicht erstellt werden da bereits eine mit dem _ selben Namen geöffnet ist " Exit Sub End If Next Wb

Hey Basti,
sehr schöne Verschönerung ;)
Interessanterweise gab es zwar vorher eine Fehlermeldung, aber das Makro hat dann trotzdem statt einer weiteren neuen Datei ein neues Datenblatt am Ende der Quelldatei hinzugefügt... ;)
So oder so... so ist's besser ;)
Ich habe das Makro dahingehend angepasst, dass auch Spalte A immer übernommen wird (wieder was gelernt ;)).
Zu Meinem erwarteten Problem mit Office für Mac: Hier wird direkt KEINE neue Datei erstellt (bzw. wird es, aber diese ist leer), sondern am Ende der Quelldatei das eben schon beschriebene neue Datenblatt eingefügt. Dieses ist aber wenigstens fehlerfrei, also alle Daten werden übernommen. Meine Frage: Hast Du dazu zufällig eine Idee zu? Wir nutzen leider in der Firma teilweise Mac mit Office für Mac (echt schlau von uns ;))
Die Fehlermeldung lautet:
Laufzeitfehler "1004": Die SaveAs-Methode des Workbook-Objektes ist fehlerhaft.
Zweite Frage: Da die neu erstellte Gesamtauswertung dann noch weiter manuell ausgewertet werden soll, frage ich mich, bzw. Dich, ob die Zieldatei vorformatiert werden kann. Hier denke ich vorrangig an die Spaltenbreite.
A = 3
B = 30
C = 17,5
D - AH = 3
Meinst Du das geht?
Ich versuch jetzt mal die bedingte Formatierung der Quelldatei dahingehend anzupassen, dass die Wochentage auch richtig eingefärbt werden in der Zieldatei ;)
Danke schon mal vorab!
Beste Grüße
Benno
PS.: Deine "Weisheit" oder eben Ahnung hätte ich gerne...fange gerade erst mit VBA an ... aber ich liebe es schon jetzt ;)

Sub Überischt() Application.CutCopyMode = False Application.ScreenUpdating = False Dim Wb As Workbook For Each Wb In Workbooks If Wb.Name = "ÜbersichtsMappe" & ".xlsx" Then MsgBox "Die Datei ÜbersichtsMappe kann nicht erstellt werden da bereits eine mit dem _ selben Namen geöffnet ist " Exit Sub End If Next Wb Dim strOrdner As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = "C:\" .Title = "Ordnerauswahl" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewList If .Show = -1 Then strOrdner = .SelectedItems(1) If Right(strOrdner, 1) "\" Then strOrdner = strOrdner & "\" Else strOrdner = "" Exit Sub End If End With WbName = ActiveWorkbook.Name WSgo = Range("N2").Value + 1 Set NewSheet = Worksheets.Add NewSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count) NewSheet.Name = "Übersicht" For i = WSgo To Worksheets.Count - 1 lngReihe = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row lngSpalte = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column 'MsgBox Cells(lngReihe, lngSpalte).Address Range(Worksheets(i).Cells(7, 2), Worksheets(i).Cells(lngReihe, lngSpalte)).Copy lngReiheUe = Worksheets("Übersicht").UsedRange.SpecialCells(xlCellTypeLastCell).Row lngSpalteUe = Worksheets("Übersicht").UsedRange.SpecialCells(xlCellTypeLastCell).Column 'MsgBox Cells(lngReiheUe, lngSpalteUe).Address Range(Worksheets("Übersicht").Cells(lngReiheUe + 1, 1), Worksheets("Übersicht").Cells( _ lngReiheUe + 1, 1)).PasteSpecial Next Application.DisplayAlerts = False Set NewBook = Workbooks.Add NewBook.SaveAs Filename:=strOrdner & "ÜbersichtsMappe.xlsx" Windows(WbName).Activate Sheets("Übersicht").Move Before:=Workbooks("ÜbersichtsMappe.xlsx").Sheets(1) Windows("ÜbersichtsMappe.xlsx").Activate With Workbooks("ÜbersichtsMappe.xlsx").Sheets.Application.Cells .Columns("A:A").ColumnWidth = 30 .Columns("B:B").ColumnWidth = 20 .Columns("C:AH").ColumnWidth = 3 End With Call Einfaerben Range(Cells(1, 1), Cells(1, 1)).Activate NewBook.Save Application.ScreenUpdating = True Application.CutCopyMode = True End Sub Sub Einfaerben() Application.ScreenUpdating = False Sheets(1).Cells.FormatConditions.Delete With Sheets(1).Cells.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Dim x As Range For Each x In ActiveSheet.UsedRange If x = "Referent" Then x.Offset(1, 0) = "-" Next x Dim Zelle As Range For Each Zelle In ActiveSheet.UsedRange List = ("B" & Zelle.Row + 2) Range(List).Activate ListRow = Range(List).End(xlDown).Row - 1 If Zelle Like "So" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)). _ Interior.Color = RGB(233, 223, 13) If Zelle Like "Sa" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)) _ .Interior.Color = RGB(231, 234, 112) If Zelle Like "Fr" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle. _ Column)).Interior.Color = RGB(52, 168, 204) Next Zelle Dim y As Range For Each y In ActiveSheet.UsedRange If y = "Referent" Then y.Offset(1, 0) = "" Next y Application.ScreenUpdating = True End Sub

Sub Einfaerben() Application.ScreenUpdating = False Sheets(1).Cells.FormatConditions.Delete With Sheets(1).Cells.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Dim rng As Range Set rng = ActiveSheet.Range(ActiveSheet.Cells(1, 2), ActiveSheet.Cells(ActiveSheet.Cells( _ 1048576, 2).End(xlUp).Row, 2)) Dim x As Range For Each x In rng If x = "Referent" Then x.Offset(1, 0) = "-" Next x Dim Zelle As Range For Each Zelle In ActiveSheet.UsedRange List = ("B" & Zelle.Row + 2) Range(List).Activate ListRow = Range(List).End(xlDown).Row - 1 If Zelle Like "So" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)). _ _ Interior.Color = RGB(233, 223, 13) If Zelle Like "Sa" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)) _ _ .Interior.Color = RGB(231, 234, 112) If Zelle Like "Fr" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(Zelle.Row, Zelle. _ Column)).Interior.Color = RGB(52, 168, 204) Next Zelle Dim y As Range For Each y In rng If y = "Referent" Then y.Offset(1, 0) = "" If y = "Lieferadresse" Then Rows(y.Row).EntireRow.Delete Next y Application.ScreenUpdating = True End Sub

Hey Ja an der Struktur darf man nix verändern sonst ist alles im A... =D
Dim x As Range
For Each x In rng
If x = "Referent" Then x.Offset(1, 0) = "-"
If x = "Lieferadresse" Then Rows(x.Row).EntireRow.Delete
Next x
Ich habe es nun hier eingefügt und ja damit kannst du die entsprechende Spalte löschen die den Namen enthält
Gruß Basti

Sub Überischt()
Application.CutCopyMode = False
Application.ScreenUpdating = False
Dim Wb As Workbook
For Each Wb In Workbooks
If Wb.Name = "ÜbersichtsMappe" & ".xlsx" Then
MsgBox "Die Datei ÜbersichtsMappe kann nicht erstellt werden da bereits eine mit dem  _
selben Namen geöffnet ist "
Exit Sub
End If
Next Wb
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
Exit Sub
End If
End With
WbName = ActiveWorkbook.Name
WSgo = Range("N2").Value + 1
Set NewSheet = Worksheets.Add
NewSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
NewSheet.Name = "Übersicht"
For i = WSgo To Worksheets.Count - 1
lngReihe = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngSpalte = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column
'MsgBox Cells(lngReihe, lngSpalte).Address
Range(Worksheets(i).Cells(7, 1), Worksheets(i).Cells(lngReihe, lngSpalte)).Copy
lngReiheUe = Worksheets("Übersicht").UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngSpalteUe = Worksheets("Übersicht").UsedRange.SpecialCells(xlCellTypeLastCell).Column
'MsgBox Cells(lngReiheUe, lngSpalteUe).Address
Range(Worksheets("Übersicht").Cells(lngReiheUe + 1, 1), Worksheets("Übersicht").Cells( _
lngReiheUe + 1, 1)).PasteSpecial
Next
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=strOrdner & "ÜbersichtsMappe.xlsx"
Windows(WbName).Activate
Sheets("Übersicht").Move Before:=Workbooks("ÜbersichtsMappe.xlsx").Sheets(1)
Windows("ÜbersichtsMappe.xlsx").Activate
With Workbooks("ÜbersichtsMappe.xlsx").Sheets.Application.Cells
.Columns("A:A").ColumnWidth = 10
.Columns("B:B").ColumnWidth = 30
.Columns("C:C").ColumnWidth = 20
.Columns("D:AH").ColumnWidth = 3
End With
Call Einfaerben
Range(Cells(1, 1), Cells(1, 1)).Activate
NewBook.Save
Set NewBook = Nothing
Application.ScreenUpdating = True
Application.CutCopyMode = True
End Sub


Sub Einfaerben()
Application.ScreenUpdating = False
Sheets(1).Cells.FormatConditions.Delete
With Sheets(1).Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Dim rng As Range
Set rng = ActiveSheet.Range(ActiveSheet.Cells(1, 3), ActiveSheet.Cells(ActiveSheet.Cells( _
1048576, 3).End(xlUp).Row, 3))
Dim x As Range
For Each x In rng
If x = "Referent" Then x.Offset(1, 0) = "-"
If x = "Lieferadresse" Then Rows(x.Row).EntireRow.Delete
Next x
Dim Zelle As Range
For Each Zelle In ActiveSheet.UsedRange
List = ("C" & Zelle.Row + 2)
Range(List).Activate
ListRow = Range(List).End(xlDown).Row - 1
If Zelle Like "So" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)). _
_
Interior.Color = RGB(233, 223, 13)
If Zelle Like "Sa" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(ListRow, Zelle.Column)) _
_
.Interior.Color = RGB(231, 234, 112)
If Zelle Like "Fr" Then Range(Cells(Zelle.Row, Zelle.Column), Cells(Zelle.Row, Zelle. _
Column)).Interior.Color = RGB(52, 168, 204)
Next Zelle
Dim y As Range
For Each y In rng
If y = "Referent" Then y.Offset(1, 0) = ""
Next y
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Zusammenführen von Datenblättern in externe Datei

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread