Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
684to688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
684to688
684to688
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro zur "Datentrennung" und Kopieren

Makro zur "Datentrennung" und Kopieren
21.10.2005 15:43:01
Sebastian
Hallo mal wieder ;-)
Ich habe ein Problem, bei dem ich keine Ahnung habe wie ich ran zu gehen habe:
Ich weiss zwar wie folgende Sache manuell abläuft, aber da ich demnächst mehr solche Daten bekomme, wäre es schön, das ganze etwas zu erleichtern:
Also: ich bekomme eine mehrere Dateien des Typs txt, Beispiel: https://www.herber.de/bbs/user/27707.txt
Diese öffne ich mit Excel und ich habe 1 Spalte mit Daten, diese sollen:
1.) Über "Text in Spalten" nach Leerzeichen getrennt werden, so dass es jeweils 6 Spalten ergeben und
2.) jeweils automatisiert in eine andere Excel-Vorlage in die Spalten J-O ab der 3 Zeile kopiert werden
...das wäre es auch schon. Klar, ist manuell auch nicht so viel Aufwand, aber automatisiert wäre schon schicker. ;-)
Danke schon mal - Sebastian

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro zur "Datentrennung" und Kopieren
21.10.2005 19:06:37
Luschi
Hallo Sebastian,
habe Die mal 1 Beispiel gemacht, wie man mit Vba txt-Dateien einliest.
ein parr kommenzare sollen den Einstieg erleichtern.
https://www.herber.de/bbs/user/27712.zip
Gruß von Luschi
aus klein-Paris
AW: Makro zur "Datentrennung" und Kopieren
22.10.2005 01:45:48
Sebastian
Danke, genau so war es gemeint.
Danke euch beiden...ist echt ein super Forum.
Ciao - Sebastian
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
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige