zusammenführen von Datenblättern in externe Datei
01.07.2016 10:25:53
Datenblättern
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