nur sichtbare Zellen kopieren
13.04.2008 00:04:00
Dirk
mit untenstehendem Makro kopiere ich ein Blatt in eine andere Datei, was auch dank Rainer (wuxinese) super funktioniert...
Nun möchte ich gern noch die Option: "nur sichtbare Zellen kopieren" ( SpecialCells(xlCellTypeVisible) )einbauen, bekomme es aber einfach nicht hin...
Kann mir jemand helfen ?
MfG Dirk
Hier mein bisheriger Code:
Sub Meldg_archivieren()
Application.ScreenUpdating = False
Dim ns, wb2, sh1, nsname, wbopen, abbr
Set sh1 = ActiveWorkbook.Sheets("Meldg")
Dim openworkbook As Workbook
wbopen = False
For Each openworkbook In Workbooks
If openworkbook.Name = "SZ-Meldungen-07-ggw.xls" Then
wbopen = True
openworkbook.Save
openworkbook.Close
Exit For
End If
Next
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\1 Archiv\SZ-Meldungen-07-ggw.xls")
nsname = InputBox("Neues Arbeitsblatt in der Zieldatei benennen!", "Wie soll das neue Blatt _
heissen ?")
If nsname = "" Then abbr = True: GoTo Abbruch
For d = 1 To wb2.Sheets.Count
If wb2.Sheets(d).Name = nsname Then nsname = "ABL " & Day(Date) & "." & _
Month(Date) & "." & Year(Date) & " " & Hour(Time) & _
"-" & Minute(Time) & "-" & Second(Time) & " Uhr"
Next d
Set ns = wb2.Sheets.Add(, Sheets(wb2.Sheets.Count))
ns.Name = nsname
sh1.UsedRange.Copy
ns.Range("a1").PasteSpecial (xlPasteFormats)
ns.Range("a1").PasteSpecial (xlPasteColumnWidths)
ns.Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats)
For i = 1 To sh1.UsedRange.Rows.Count
ns.Rows(i).RowHeight = sh1.UsedRange.Rows(i).RowHeight
Next i
Abbruch:
If nsname = "" Then MsgBox "Kein gueltiger Name oder Abbruch... Kopie nicht erstellt!"
wb2.Save
If abbr = True And wbopen = False Then
Workbooks("SZ-Meldungen-07-ggw.xls").Close
sh1.Activate
Else
ns.Activate
ns.Range("a1").Select
End If
Application.ScreenUpdating = True
Set ns = Nothing
Set wb2 = Nothing
Set sh1 = Nothing
End Sub