AW: Makro zur "Datentrennung" und Kopieren
21.10.2005 23:45:01
Erich
Hallo Sebastian,
so ginge es auch:
Sub Textfile_import()
Dim strTextdat As String
Dim wbZiel As Workbook, wsZiel As Worksheet, rgZiel As Range
Dim istErfolgt As Boolean
' ############################################ Vorgaben
strTextdat = "F:\Exc\w-w-w\27707.txt"
Set wbZiel = ActiveWorkbook
Set wsZiel = wbZiel.Sheets("Tabelle1")
Set rgZiel = wsZiel.Range("J3:P1000") ' alter Inhalt wird gelöscht!
' ############################################ Vorgabenende
' Aufruf:
Call TxtImportPunkt(strTextdat, wbZiel, wsZiel, rgZiel, istErfolgt)
' Weiterverarbeitung:
If istErfolgt Then
MsgBox strTextdat & " wurde importiert."
Application.Calculate ' falls nötig
Else
MsgBox strTextdat & " wurde nicht importiert."
End If
Set wbZiel = Nothing
Set wsZiel = Nothing
Set rgZiel = Nothing
End Sub
Sub TxtImportPunkt(strTxt$, _
wbZ As Workbook, _
wsZ As Worksheet, _
rgZ As Range, _
rc As Boolean)
' Import einer Textdatei mit Zahlen,
' die durch Leerzeichen getrennt sind
' und einen Dezimalpunkt statt des Kommas enthalten
' Alle Punkte werden durch Kommata ersetzt (auch in evtl. vorhandenen Texten!).
' Erich Gier (Mail: eri474 bei web.de) 21.10.2005
Dim calcMode As XlCalculation, updateMode As Boolean
Dim wbText As Workbook, rg As Range, Abbruch As Boolean
rc = False
' Beschleunigung
updateMode = Application.ScreenUpdating
calcMode = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Textdatei öffnen, Text in Spalte A
Workbooks.OpenText Filename:=strTxt, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
TrailingMinusNumbers:=True
Set wbText = ActiveWorkbook
Set rg = ActiveSheet.UsedRange
rg.NumberFormatLocal = "Standard" ' (hat sonst Format "Text")
' Punkt durch Komma ersetzen
rg.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Text in Spalten aufteilen
rg.TextToColumns Destination:=Cells(1, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
FieldInfo:=Array(Array(1, 1)), TrailingMinusNumbers:=True
Set rg = ActiveSheet.UsedRange
' Zielbereichsgröße prüfen
If rg.Rows.Count > rgZ.Rows.Count Then
If MsgBox("Der Zielbereich hat nur" & Str(rgZ.Rows.Count) _
& " Zeilen," & Chr(10) & "kopiert werden sollen" _
& Str(rg.Rows.Count) & " Zeilen." _
& Chr(10) & Chr(10) & "Weitermachen?", _
vbYesNo + vbDefaultButton2 + vbQuestion, "Textdatei-Import") _
<> vbYes Then Abbruch = True
End If
If rg.Columns.Count <> rgZ.Columns.Count Then
If MsgBox("Der Zielbereich hat" & Str(rgZ.Columns.Count) _
& " Spalten," & Chr(10) & "kopiert werden sollen" _
& Str(rg.Columns.Count) & " Spalten." _
& Chr(10) & Chr(10) & "Weitermachen?", _
vbYesNo + vbDefaultButton2 + vbQuestion, "Textdatei-Import") _
<> vbYes Then Abbruch = True Else Abbruch = False
End If
' Kopie erstellen
If Not Abbruch Then
rgZ.ClearContents ' Zielbereich löschen
ActiveSheet.UsedRange.Copy ' Werte kopieren
wbZ.Activate
wsZ.Activate ' Werte einfügen
rgZ.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
rc = True
End If
' Textdatei schließen
Application.DisplayAlerts = False
wbText.Close SaveChanges:=False
Application.DisplayAlerts = True
Set wbText = Nothing
' Ende, aufräumen
rgZ.Cells(1, 1).Select
Application.ScreenUpdating = updateMode
Application.Calculation = calcMode
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort