Zahlenformat VBA
06.01.2015 15:49:57
andthen
ich sitze nun seit längerer Zeit an einer kleinen Sache und finde die Lösung einfach nicht.
Ich kopiere mithilfe eines Makros 2 Spalten aus einer Quelldatei in eine Zieldatei.
Die Zahlen 1000 als Zahlen und mit einem Tausenderpunkt getrennt.
Kopiere ich nun mit meinem Makro werden alle Zahlen, die als Standard formatiert sind und Dezimalzahlen sind, als in Text gespeicherte Zahlen dargestellt.
Alle Zahlen, die als Standard formatiert und Alle Zahlen, die > 1000 und mit einem Tausendertrennzeichen versehen sind, werden in Dezimalzahlen umgewandelt (Bsp. 1.416 => 1,416). In der Zieldatei sind alle Daten als Standard formatiert.
Stelle ich nun in der Quelldatei die Zahlen mit Tausenderzeichen manuell von Zahl auf Standard um funktioniert das in diesem Fall. Daher war meine Idee in der geöffneten Quelldatei die benötigten Daten auf Standard umzustellen. Leider entstehen dabei wieder Dezimalzahlen und ich weiß nicht warum.
Nach ein Paar Versuchen ist mir nun aufgefallen, dass das Makro die Datei bereits falsch öffnet. Stoppe ich meinen Code nach dem Öffnen der Quelldatei werden die Zahlen bereits falsch dargestellt und sind als Standard formatiert. Wie kann ich dies verhindern? Wie öffnet mein Makro originalgetreu? Die Quelldatei ist ein 97 - 03 .xls Worksheet hängt es damit zusammen?
Mein Problem bezieht sich übrigens auf meinen Post 1399042 "Makro Einfügen Formatänderung" vom 19.12. Mit meinen Trennzeichen stimmt alles, das kann ignoriert werden.
Da ich Azubi bin konnte ich das Ganze über die Ferien nicht testen und weiß leider nicht wie ich diesen Thread wieder öffne.
Zu guter letzte noch meinen aktuellen Code
Option Explicit
Sub Import_mit_Dialog()
Dim Quelle As Object, Ziel As Object
Dim Datei As String
Dim lr As Long, i As Long
'Dim x As Double
'Dim letzteZeile As Integer
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("alle Excel-Dateien(*.xls),*xls")
'Abbrechen falls keine Datei ausgewählt
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
'MsgBox "Ausgewählte Datei: " & Datei, , ""
Application.DisplayAlerts = False
'Ausgewählte Datei öffnen
Workbooks.Open Filename:=Datei
Set Quelle = ActiveWorkbook.Worksheets(1)
Set Ziel = ThisWorkbook.Worksheets("Basisdaten")
'letzteZeile = ActiveWorkbook.Worksheets(1).Cells.SpecialCells(xlLastCell).Row
'MsgBox letzteZeile
' With Worksheets(1)
' For x = 4 To letzteZeile
' .Cells(x, 18) = CDbl(.Cells(x, 6))
' .Cells(x, 18).NumberFormat = "General"
'Next
' End With
'zu kopierende Daten auswählen und einfügen
Quelle.Range("D:D").Copy
Ziel.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Quelle.Range("O:O").Copy
Ziel.Cells(1, 5).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Quelle.Range("S:S").Copy
Ziel.Cells(1, 6).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Ziel.Range("A2").Value = "Materialkurztext"
Ziel.Range("B2").Value = "Beschichtung"
Ziel.Range("C2").Value = "DN"
Ziel.Range("D2").Value = "Länge"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Ziel.Select
'Zeile 1 löschen und Spaltenbreite festlegen
Rows("1").Delete
Columns("A").ColumnWidth = "40"
Columns("B:F").ColumnWidth = "15"
Calculate
'Leerzeilen löschen
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
If WorksheetFunction.CountA(Cells(i, 1), Cells(i, 5)) = 0 Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
'Speicher freigeben
Set Quelle = Nothing
Set Ziel = Nothing
ThisWorkbook.Worksheets("Datenverarbeitung").Select
'Call Hochkomma
'Call TestSummieren
Exit Sub
Fehler:
Set Quelle = Nothing
Set Ziel = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Ich hoffe ich konnte alles gut beschreiben und ihr könnt mir weiterhelfen.
Vielen Dank schon im Voraus!
Mit freundlichem Gruß
Robert