Hallo M.O.
leider komme ich mit deinem letzteren Code nicht zurecht,
schon alleine dadurch, weil ich alle diese Makros einzeln brauche, wie hier dargestellt.
wenn ich nach dem Datenimport, dein Makro verwende kommt der Lauftzeitfehler 1004
Sub Reichweite()
If ActiveSheet.Name <> "Datentabelle" Then
ActiveSheet.Name = "Reichweite"
End If
End Sub
Sub Summetabellenblatteinfügen()
anzahl = Sheets.Count
Sheets.Add
ActiveSheet.Name = "Summe"
Sheets("Summe").Move after:=Sheets(anzahl + 1)
End Sub
Sub Datenimport()
Dim Importdatei$, Verzeichnis$
Verzeichnis = "P:\Departments1\CP_Gesamt\2_Bestandsbewertung\SAP-Spools"
On Error Resume Next
ChDir Verzeichnis
Importdatei = Application.GetOpenFilename("Textdateien (*.txt), *.txt")
Application.ScreenUpdating = False
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Importdatei, _
Destination:=Range("A1"))
.TextFileSemicolonDelimiter = True
.TextFileTabDelimiter = True
.Refresh BackgroundQuery:=False
End With
End Sub
Sub Laschenloeschen()
'
' laschen loeschen Makro
' Makro am 16.10.2012 von z002tsup aufgezeichnet
'
'
Sheets("Tabelle2").Select
Selection.ClearContents
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Tabelle3").Select
ActiveWindow.SelectedSheets.Delete
End Sub
Sub Mehreredinge()
'
' Mehreredinge Makro
' Makro am 16.10.2012 von z002tsup aufgezeichnet
'
'
Columns("A:A").Select
Range("A31").Activate
Selection.Insert Shift:=xlToRight
Selection.ColumnWidth = 16.25
ActiveWindow.SmallScroll Down:=-72
Range("A1").Select
ActiveCell.FormulaR1C1 = "Dispo_Name"
Columns("C:C").Select
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
ActiveCell.FormulaR1C1 = "Reichweite"
Range("I3").Select
End Sub
_______
Sub Leermachen()
Dim zeile As Variant
For zeile = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
'Hier wird der Arbeitsbereich (Anzahl der Spalten) angegeben
With Range(Cells(zeile, 1), Cells(zeile, 4))
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then
Rows(zeile).Delete
End If
End With
Next
End Sub
Sub Summe_kopieren()
Dim zeile, szeile As Long
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
_______
und diesen Teil, den du mir netter weise dazu geschrieben hast,
braeuchte ich noch
'letzte Zeile im Arbeitsblatt "Reichweite" ermitteln
lzeile = Worksheets(blatt).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'überflüssige Überschriften im Blatt Reichweite löschen
For zeile = 6 To lzeile
If Left(Sheets(blatt).Cells(zeile, 1).Value, 3) = "Dis" Then
Sheets(blatt).Range(Cells(zeile - 3, 1), Cells(zeile + 2, 1)).EntireRow.Delete xlShiftUp
End If
Next zeile
'Suchen wo Summenbildung anfängt
'letzte Zeile im Arbeitsblatt mit Daten wird neu ermitteln
lzeile = Worksheets(blatt).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Zeilen suchen, in der "Summe" oder "Gesamtsumme" steht
For zeile = lzeile To 6 Step -1
If Left(Sheets(blatt).Cells(zeile, 3).Value, 5) = "Summe" And Sheets(blatt).Cells(zeile, 11).Value = 0 Then anfang = zeile
If Left(Sheets(blatt).Cells(zeile, 3).Value, 11) = "Gesamtsumme" Then ende = zeile
Next zeile
'letzte beschriebene Zeile im Arbeitsblatt Summe ermitteln und um 1 erhöht
slzeile = Worksheets("Summe").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'nun wird der letze Summenblock kopiert und gelöscht
With Sheets(blatt).Range(Cells(anfang, 1), Cells(ende, 1))
.EntireRow.Copy Destination:=Worksheets("Summe").Cells(slzeile, 1)
.EntireRow.Delete xlShiftUp
End With
'Löschen von leeren Zeilen
'letzte Zeile im Arbeitsblatt mit Daten wird neu ermitteln
lzeile = Worksheets(blatt).UsedRange.SpecialCells(xlCellTypeLastCell).Row
For zeile = lzeile To 6 Step -1
'Hier wird der Arbeitsbereich angegeben: Spalten A bis S
With Sheets(blatt).Range(Cells(zeile, 1), Cells(zeile, 19))
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then
Rows(zeile).Delete
End If
End With
Next zeile
_____________________
Leider wurde mir als ich dein Makro ausgefuehrt habe, nicht die Summen in die Summenlasche kopiert, lediglich eine Überschrift, die nicht benötigt wird
'Überschriften in Tabellenblatt "Summe" kopieren
Sheets(blatt).Range(Cells(2, 1), Cells(5, 1)).EntireRow.Copy Destination:=Worksheets("Summe").Cells(1, 1)
der Rest ist weltklasse!
