Excel – Nur benutzte Zellen auf neues Blatt kopieren und als csv speichern

Nur benutzte Zellen auf neues Blatt kopieren und als csv speichern, diesen Fall trifft man in Firmen öfter als einem lieb ist

Hin und wieder gib es kuriose Fälle in denen man mit Excel Applikationslogik erzeugen muss.

Im konkreten Fall hat ein Kunde alle Umleitungen (Redirects) auf seiner Webseite mit einer Excel Liste gepflegt. (ja, richtig gelesen. sowas gibt es)
Diese Tabelle wurde mit der Zeit immer länger und die neuen Änderungen kamen via eMail und wurden einfach in die Tabelle eingefügt.
Danach kam der manuelle Schritt aus der Tabelle eine ApacheMappingTable für den Apache WebServer zu erstellen.
Der Trick ist nur die benutzten Zellen auszulesen und leere Zeilen und Kommentarzeilen clever zu überspringen.

Generate Apache Mapping Tables from Excel Table

Sub hg_generate_Apache_Mappings()
'
' hg_generate_Apache_Mappings Makro
' Generate Apache Mapping Tables from Excel Table

Dim zeilen As Long
Dim y_quell As Long
Dim y_ziel As Long
Dim Current As Worksheet
y_ziel = 1
' clear destination sheets to avoid errors
With hg_gesamt
.Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Clear
End With
With hg_map_old2new_name
.Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Clear
End With
With hg_map_old_name2new_group
.Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Clear
End With
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
' Ignore my hg_ data sheets
If InStr(1, Current.CodeName, "hg_", vbTextCompare) = 0 Then
' Find last used line
' zeilen = Current.UsedRange.Rows.Count
zeilen = Current.Cells(Rows.Count, 1).End(xlUp).Row
' fill hg_gesamt.Cells with county content
For y_quell = 1 To zeilen
' Range ist schoener und schneller aber nervt beim debuggen
hg_gesamt.Cells(y_ziel, 1).Value = Current.Cells(y_quell, 1).Value
hg_gesamt.Cells(y_ziel, 2).Value = Current.Cells(y_quell, 2).Value
hg_gesamt.Cells(y_ziel, 3).Value = Current.Cells(y_quell, 3).Value
hg_gesamt.Cells(y_ziel, 4).Value = Current.Cells(y_quell, 4).Value
hg_gesamt.Cells(y_ziel, 5).Value = Current.Cells(y_quell, 5).Value
hg_gesamt.Cells(y_ziel, 6).Value = Current.Cells(y_quell, 6).Value
' hg_map_old2new_name
hg_map_old2new_name.Cells(y_ziel, 1).Value = Current.Cells(y_quell, 1).Value
hg_map_old2new_name.Cells(y_ziel, 2).Value = Current.Cells(y_quell, 2).Value
' hg_map_old_name2new_group
hg_map_old_name2new_group.Cells(y_ziel, 1).Value = Current.Cells(y_quell, 1).Value
hg_map_old_name2new_group.Cells(y_ziel, 2).Value = Current.Cells(y_quell, 4).Value
' increment destination rows
y_ziel = y_ziel + 1
Next
End If
Next
Dim AWName As String
AWName = ActiveWorkbook.name

'save hg_map_old2new_name
hg_map_old2new_name.Select
ActiveWorkbook.SaveAs Filename:="hg-mapping-table.txt", FileFormat:=xlText, CreateBackup:=False
' save hg_map_old_name2new_group
hg_map_old_name2new_group.Select
ActiveWorkbook.SaveAs Filename:="hg-mapping-table-name-old-2-new.txt", FileFormat:=xlText, CreateBackup:=False
' save hg_paths
hg_paths.Select
ActiveWorkbook.SaveAs Filename:="hg-mapping-table-paths.txt", FileFormat:=xlText, CreateBackup:=False
' back to Macro Sheet
hg_gesamt.Select
ActiveWorkbook.SaveAs Filename:=AWName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=True
End Sub