Zusammenführen von Datenblättern in externe Datei

Datenblättern · 2016-06-22T21:08:22+00:00

Hey zusammen, beigefügte Beispieldatei dient bei uns in der Firma zur Ressourcenverwaltung. https://www.herber.de/bbs/user/106437.xlsx Ich habe nun bereits diverse Markos recherchiert, aber leider hat keines genau meinen gewünschten Zweck erfüllt: - in dieser Beispieldatei sollen 5 / 7 Datenblätter per Makro in einer neue Datei (wichtig: eine neue zweite Datei, nicht neues Datenbaltt in der gleichen Datei) zusammengefügt werden - alle Inhalte ab Zeile 7 der Datenblätter in der Reihenfolge der Datenblätter untereinander weggeschrieben - alle Inhalte in ein Datenblatt namens "Gesamtübersicht" In diesem Beispiel sind es die Datenblätter: -Arterienscreening -AtemvolumenCheck -AusdauerCheck -BodyAge -S3Check Die anderen Datenblätter (Auswahl und Projekte) sollen unberücksichtigt bleiben. In der Originaldatei sind es ca. 20 weitere Datenblätter die berücksichtigt werden sollen (auf Grund der Größenbeschrenkung im Upload musste ich verkleinern). Ferner auch noch weitere Datenblätter die unberücksichtigt bleiben sollen. Das Makro der Zieldatei müsste also eine Liste der zu berücksichtigen Datenblätter nutzen oder so... Die Zieldatei und die Quelldatei liegen immer im gleichen Ordner, jener kann aber (da unterschiedliche Nutzer) variabel sein. Die Quelldatei hat aber immer den gleichen Namen: Ressourcen_Kalender_2016 oder eben _2017 etc. Kann mir jemand helfen? Ich würde mich tierisch freuen... Beste Grüße Benno

Also bei mir wird es richtig Markiert FR Blau Sa gelb hell So gelb dunkel.Deshalb weis ich nicht was du mit -1 Spalte meinst?

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
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, 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

Zusammenführen von Datenblättern in externe Datei

Forumthread: Zusammenführen von Datenblättern in externe Datei

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Zusammenführen von Datenblättern in externe Datei

Forumthread: Zusammenführen von Datenblättern in externe Datei

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread