dazu würde ich die Werte in eine Exceltabelle kopieren, dann bleiben auch die Formate erhalten.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub exportValues()
Dim objWB As Workbook, objSh As Worksheet
Dim strFile As String
Dim vntSheets As Variant
Dim rng As Range, rngValues As Range
Dim lngIndex As Long, lngRow As Long, lngFormat As Long
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
vntSheets = Array("Tabelle1", "Tabelle2")
strFile = Application.GetSaveAsFilename("Werte_" & ThisWorkbook.Name, "Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm")
If strFile = CStr(False) Then Exit Sub
Set objWB = Workbooks.Add(xlWBATWorksheet)
Set objSh = objWB.Sheets(1)
For lngIndex = 0 To UBound(vntSheets)
Set rngValues = Nothing
On Error Resume Next
Set rngValues = ThisWorkbook.Sheets(vntSheets(lngIndex)).UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngValues Is Nothing Then
For Each rng In rngValues.Cells
lngRow = lngRow + 1
objSh.Cells(lngRow, 1) = vntSheets(lngIndex)
objSh.Cells(lngRow, 2) = rng.Address
rng.Copy objSh.Cells(lngRow, 3)
Next
End If
Next
getFileExtAndFormat objWB, "", lngFormat
objWB.SaveAs strFile, FileFormat:=lngFormat
objWB.Close
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'exportValues'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objSh = Nothing
Set objWB = Nothing
Set rng = Nothing
Set rngValues = Nothing
End Sub
Sub importValues()
Dim objWB As Workbook
Dim rng As Range
Dim strFile As String
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm")
If strFile = CStr(False) Then Exit Sub
Set objWB = Workbooks.Open(strFile)
For Each rng In objWB.Sheets(1).Columns(1).SpecialCells(xlCellTypeConstants)
rng.Offset(0, 2).Copy ThisWorkbook.Sheets(rng.Text).Range(rng.Offset(0, 1).Text)
Next
objWB.Close False
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'importValues'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objWB = Nothing
Set rng = Nothing
End Sub
Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function