Makro für csv Import in Excel - bitte um Hilfe gegen Rechnung
Hallo Leute,
wer kann mir unkompliziert ein Makro anpassen, das ich hier auf der Platform gefunden habe, von Colinardo geschrieben.
Bei mir läuft es nicht, ich krieg Laufzeitfehler in Zeile 49 oder in 62 nicht hin.
Das Script: Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen ...
Sub SpaltenNebeneinander()
Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer, fso As Object, f As Object
Const CSVPFAD = "C:\Users\Kempe\Desktop\Arbeit-Lokal\Kempe-Calibration_factory-Al-Cu-C\quantification"
Set fso = CreateObject("Scripting.Filesystemobject")
Set ws = Worksheets(1)
ws.Range("A:ZZ").Clear
Set startRange = ws.Range("A2")
Set curRange = startRange
Application.DisplayAlerts = False
For Each f In fso.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
importCSV f.Path, ";", curRange, True
curRange.Offset(-1, 0).Value = f.Name
curRange.Offset(-1, 0).Font.Bold = True
Set curRange = curRange.End(xlToRight).Offset(0, 1)
End If
Next
Application.DisplayAlerts = True
Set fso = Nothing
End Sub
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
Dim fso As Object, regex As Object, patNumber As String, arrLines As Variant, rngCurrent As Range, intStart As Integer, cols As Variant, c As Integer, wert As String, matches As Object, i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set regex = CreateObject("vbscript.regexp")
patNumber = "^([\d\.,\+\-]+)$"
arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
Set rngCurrent = targetRange
If importHeader Then
intStart = 2
Else
intStart = 3
End If
For i = intStart To UBound(arrLines)
If arrLines(i) <> "" Then
cols = Split(arrLines(i), delim, -1, vbTextCompare)
For c = 0 To UBound(cols)
rngCurrent.Offset(0, c).ClearFormats
wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare))
' check for Numberformat
regex.Pattern = patNumber
Set matches = regex.Execute(wert)
If matches.Count > 0 Then
wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare)
End If
' set value in cell
rngCurrent.Offset(0, c).Value = wert
Next
Set rngCurrent = rngCurrent.Offset(1, 0)
End If
Next
Set fso = Nothing
Set regex = Nothing
End Function
*
Meine csv Datei:
#FORMAT : EMSA
#VERSION : 1.0
#TITLE : Messung 1
#DATE : 12-May-2020
#TIME : 12:10
#OWNER : undisclosed
#NPOINTS : 2048.
#NCOLUMNS : 1.
#XUNITS : eV
#YUNITS : counts
#DATATYPE : Y
#XPERCHAN : 9.7431
#OFFSET : -33.9785
#SIGNALTYPE : EDS
#XLABEL : Energy
#YLABEL : Counts
#BEAMKV -kV: 15.0000
#ELEVANGLE-dg: 19.0000
#AZIMANGLE-dg: 0.0
#LIVETIME -s: 26.9196
#REALTIME -s: 36.2228
#CHOFFSET : -3.
##MNFWHM : 125.2530
#SPECTRUM : Data Starts Here
95.
115.
107.
91.
[….insgesamt 2048 Datenzeilen…]
113.
88.
134.
135.
#ENDOFDATA :
**
Target Excel Ergebnis soll:
einen Importordner aufrufen, am besten mit User-Auswahl
beliebig viele csv importieren, die in dem Ordner enthalten sind und nebeneinander schreiben
und über jede Spalte den original Dateinamen.
Das gewünschte Ergebnis sieht so aus, wie im Screenshot...
vielen Dank
andre
wer kann mir unkompliziert ein Makro anpassen, das ich hier auf der Platform gefunden habe, von Colinardo geschrieben.
Bei mir läuft es nicht, ich krieg Laufzeitfehler in Zeile 49 oder in 62 nicht hin.
Das Script: Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen ...
Sub SpaltenNebeneinander()
Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer, fso As Object, f As Object
Const CSVPFAD = "C:\Users\Kempe\Desktop\Arbeit-Lokal\Kempe-Calibration_factory-Al-Cu-C\quantification"
Set fso = CreateObject("Scripting.Filesystemobject")
Set ws = Worksheets(1)
ws.Range("A:ZZ").Clear
Set startRange = ws.Range("A2")
Set curRange = startRange
Application.DisplayAlerts = False
For Each f In fso.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
importCSV f.Path, ";", curRange, True
curRange.Offset(-1, 0).Value = f.Name
curRange.Offset(-1, 0).Font.Bold = True
Set curRange = curRange.End(xlToRight).Offset(0, 1)
End If
Next
Application.DisplayAlerts = True
Set fso = Nothing
End Sub
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean)
Dim fso As Object, regex As Object, patNumber As String, arrLines As Variant, rngCurrent As Range, intStart As Integer, cols As Variant, c As Integer, wert As String, matches As Object, i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set regex = CreateObject("vbscript.regexp")
patNumber = "^([\d\.,\+\-]+)$"
arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
Set rngCurrent = targetRange
If importHeader Then
intStart = 2
Else
intStart = 3
End If
For i = intStart To UBound(arrLines)
If arrLines(i) <> "" Then
cols = Split(arrLines(i), delim, -1, vbTextCompare)
For c = 0 To UBound(cols)
rngCurrent.Offset(0, c).ClearFormats
wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare))
' check for Numberformat
regex.Pattern = patNumber
Set matches = regex.Execute(wert)
If matches.Count > 0 Then
wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare)
End If
' set value in cell
rngCurrent.Offset(0, c).Value = wert
Next
Set rngCurrent = rngCurrent.Offset(1, 0)
End If
Next
Set fso = Nothing
Set regex = Nothing
End Function
*
Meine csv Datei:
#FORMAT : EMSA
#VERSION : 1.0
#TITLE : Messung 1
#DATE : 12-May-2020
#TIME : 12:10
#OWNER : undisclosed
#NPOINTS : 2048.
#NCOLUMNS : 1.
#XUNITS : eV
#YUNITS : counts
#DATATYPE : Y
#XPERCHAN : 9.7431
#OFFSET : -33.9785
#SIGNALTYPE : EDS
#XLABEL : Energy
#YLABEL : Counts
#BEAMKV -kV: 15.0000
#ELEVANGLE-dg: 19.0000
#AZIMANGLE-dg: 0.0
#LIVETIME -s: 26.9196
#REALTIME -s: 36.2228
#CHOFFSET : -3.
##MNFWHM : 125.2530
#SPECTRUM : Data Starts Here
95.
115.
107.
91.
[….insgesamt 2048 Datenzeilen…]
113.
88.
134.
135.
#ENDOFDATA :
**
Target Excel Ergebnis soll:
einen Importordner aufrufen, am besten mit User-Auswahl
beliebig viele csv importieren, die in dem Ordner enthalten sind und nebeneinander schreiben
und über jede Spalte den original Dateinamen.
Das gewünschte Ergebnis sieht so aus, wie im Screenshot...
vielen Dank
andre
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 571780
Url: https://administrator.de/forum/makro-fuer-csv-import-in-excel-bitte-um-hilfe-gegen-rechnung-571780.html
Ausgedruckt am: 18.04.2025 um 13:04 Uhr
6 Kommentare
Neuester Kommentar
Servus andre,
Grüße Uwe
Zitat von @superbeginner:
ja klar,
ich habs zwei mal mit einer persönlichen Nachricht versucht... das ist jetzt schon ne Weile her.
Du hast Post, deine erste PN hat mich wohl irgendwie in der Masse an Anfragen nicht erreicht.ja klar,
ich habs zwei mal mit einer persönlichen Nachricht versucht... das ist jetzt schon ne Weile her.
Grüße Uwe
Gerne, freut mich für dich
.
Schönes Wochenende.
Uwe
Wenns das dann war, die Frage bitte noch auf gelöst setzen. Merci.
Schönes Wochenende.
Uwe
Wenns das dann war, die Frage bitte noch auf gelöst setzen. Merci.