AW: Variable Spalten kopieren + leere Zeilen löschen
10.09.2018 23:34:51
fcs
Hallo Markus,
hier 2. Varianten fr das kopieren der Daten + eine Routine zum Löschen der Zeilen mit nur 0-Werten und(oder leeren Zellen.
Gruß
Franz
Sub kopieren_2()
'Zielblätter werden jeweils neu angelegt
Dim s As Long
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Const iStep As Long = 11 'Anzahl Spalten je Land
Const lSpa2 As Long = 5 'Spalte E - Spalte 1 des 1. Landes
With Application
.ScreenUpdating = False
End With
Set wksQuelle = Sheets("Tabelle1")
With wksQuelle
For s = lSpa2 To .Cells(2, .Columns.Count).End(xlToLeft).Column Step iStep
With ActiveWorkbook
'neues Blatt anfügen
Set wksZiel = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
End With
'Spalten A bis D kopieren
.Range(.Columns(1), .Columns(lSpa2 - 1)).Copy wksZiel.Cells(1, 1)
'Länder-Spalten kopieren
.Range(.Columns(s), .Columns(s + iStep - 1)).Copy wksZiel.Cells(1, lSpa2)
Call prcZeilenLoeschen(wks:=wksZiel, Spa1:=lSpa2, lSpaL:=lSpa2 + iStep - 1)
Next
End With
With Application
.ScreenUpdating = True
End With
End Sub
Sub kopieren_3()
'die Zielblätter sind schon vorhanden
Dim s As Long, iBlatt As Integer
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Const iStep As Long = 11 'Anzahl Spalten je Land
Const lSpa2 As Long = 5 'Spalte E - Spalte 1 des 1. Landes
With Application
' .ScreenUpdating = False
End With
Set wksQuelle = Sheets("Tabelle1")
iBlatt = 2 '1. Blatt in das Länder-Daten eingetragen werden sollen
With wksQuelle
For s = lSpa2 To .Cells(2, .Columns.Count).End(xlToLeft).Column Step iStep
With ActiveWorkbook
'Zielblatt setzen
Set wksZiel = .Worksheets(iBlatt)
End With
'Spalten A bis D kopieren
.Range(.Columns(1), .Columns(lSpa2 - 1)).Copy wksZiel.Cells(1, 1)
'Länder-Spalten kopieren
.Range(.Columns(s), .Columns(s + iStep - 1)).Copy wksZiel.Cells(1, lSpa2)
Call prcZeilenLoeschen(wks:=wksZiel, Spa1:=lSpa2, lSpaL:=lSpa2 + iStep - 1)
iBlatt = iBlatt + 1 'Blattzähler erhöhen
Next
End With
With Application
' .ScreenUpdating = True
End With
End Sub
Sub prcZeilenLoeschen(wks As Worksheet, Spa1 As Long, lSpaL As Long)
Dim Zeile As Long, Spalte As Long, bolLoeschen As Boolean
Dim Zeile_L As Long
Dim SpaM As Long
SpaM = lSpaL + 1 'Nr. der Hilfsspalte zum markieren der zu löschenden Spalten
With wks
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
'zu löschenden Zeilen markieren
For Zeile = 2 To Zeile_L
bolLoeschen = True
For Spalte = Spa1 To lSpaL
If Trim(.Cells(Zeile, Spalte).Text) "" And .Cells(Zeile, Spalte).Text "0" _
Then
bolLoeschen = False
Exit For
End If
Next
If bolLoeschen = True Then
.Cells(Zeile, SpaM).Value = True
End If
Next
'markierte Zeilen löschen
With .Range(.Cells(1, SpaM), .Cells(Zeile_L, SpaM))
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
.SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete shift:=xlShiftUp
End If
End With
End With
End Sub