VBA Makro jede 2te Zeile

Computer: Software & Programmierung Visual Basic
#1

Hallo zusammen,

folgendes Problem, ich habe ca. 173258 txt Dateien und möchte diese in Excel einfügen. Nun habe ich den unten angegebenen Code von einem User hier übernommen und nur kleinigkeiten geändert. Jetzt brauche ich noch folgendes. Mein Ziehl ist es, das die Daten aus der txt Datei in eine neue Excel Mappe übernommen wird und dabei jede 2te Zeile beschrieben wird. Also 2 Zeilen werden gefüllt A1 bis S1 und B2 bis S2 dann müssen 2 Zeilen\Spalten lehr bleiben, anschließend A5 bis S5 und A6 bis S6 usw. Also führ jede Hilfe wäre ich sehr dankbar.

Sub Start()

Application.DisplayAlerts = False

Dim strMaster As String
Dim strPath As String
Dim strFile As String
Dim intA As Integer

strMaster = ActiveWorkbook.Name

'Bitte den Pfad verfolständigen bsp.: …\Messdaten#100030"
strPath = „X:\41-Qualitymanagement\inspection of incoming goods_Wareneingangskontrolle\WEK\Externe Vermessung von Bauteilen\Eumetron\Messdaten…“

Columns(„C:Q“).Select
Selection.ClearContents

For i = 1 To 540

On Error Resume Next

intA = i
strFile = Range(„A“ & i).Value

Call Kopieren(strPath, strFile, intA, strMaster)

Next i

Application.DisplayAlerts = True

End Sub

Function Kopieren(strPath As String, strFile As String, intA As Integer, strMaster As String)

Workbooks.Open Filename:=strPath & strFile
Range(„A11:AN11,A16:AN16“).Select
Selection.Copy
Windows(strMaster).Activate
Range(„D“ & intA).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

=False, Transpose:=False

Windows(strFile).Activate
Application.CutCopyMode = False

ActiveWindow.Close

End Function

#2

Hallo Christian,

ich habe ca. 173258 txt Dateien

endlich mal eine genaue circa Angabe :smile:

Also 2 Zeilen werden gefüllt A1 bis S1 und B2 bis S2 dann
müssen 2 Zeilen\Spalten lehr bleiben, anschließend A5 bis S5
und A6 bis S6 usw. Also führ jede Hilfe wäre ich sehr dankbar.

vielleicht so (ungetestet)

Option Explicit

Sub Start()
Application.DisplayAlerts = False
Dim strPath As String, strFile As String, intA As Integer
On Error Resume Next
'Bitte den Pfad verfolständigen bsp.: ...\Messdaten\#100030\"
strPath = "X:\41-Qualitymanagement\inspection of incoming goods\_Wareneingangskontrolle\WEK\Externe Vermessung von Bauteilen\Eumetron\Messdaten\...\"
Columns("C:Q").ClearContents
For intA = 1 To 540
 strFile = Range("A" & intA).Value
 Call Kopieren(strPath, strFile, intA)
Next intA
Application.DisplayAlerts = True
End Sub

Function Kopieren(strPath As String, strFile As String, intA As Integer)
With ThisWorkbook.Worksheets("Tabelle1")
 Workbooks.Open Filename:=strPath & strFile
 ActiveWorkbook.Range("A11:AN11,A16:AN16").Copy
 .Range("D" & (intA - 1) \* 3 + 1).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 ActiveWorkbook.Close savechanges:=True
End With
End Function

Gruß
Reinhard

#3

Servus,

also erst mal danke für die schnelle Antwort. Es sind sogar noch mehr TXT Dateien als ich angegeben habe :smiley:.
Also leider geht das so gar nicht mehr, die Zeilen und Spalten die ich nicht brauche werden nicht mehr gelöscht und es wird auch nicht jede 2te Zeile/Spalte freigelassen. Generell ist das alle Käse mit dem makro, aber da es so viele TXT Dateien sind die ich jede Woche bearbeiten muss brauch ich einfach so ein Makro ^^. Also wenn man Irgendwas brauch dann einfach sagen, ansonsten Danke für jede Hilfe.

Gruß Christian

#4

Also leider geht das so gar nicht mehr, die Zeilen und Spalten
die ich nicht brauche werden nicht mehr gelöscht und es wird
auch nicht jede 2te Zeile/Spalte freigelassen. Generell ist
das alle Käse mit dem makro, aber da es so viele TXT Dateien
sind die ich jede Woche bearbeiten muss brauch ich einfach so
ein Makro ^^. Also wenn man Irgendwas brauch dann einfach
sagen, ansonsten Danke für jede Hilfe.

Hallo Christian,

ändern sich alle txt-Dateien jede Woche oder sind das nur rel. wenige die sich ändern? Dann könnte man die Geschwindigkeit noch steigern.
Du siehst in der Statusleiste den Fortschritt und die geschätzte Restzeit.

Sub Starten()
Dim strFile As String, intA As Integer, T As Single, F As Single
Const Anz As Long = 540
T = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo hell
'Bitte den Pfad verfolständigen bsp.: ...\Messdaten\#100030\"
strFile = "X:\41-Qualitymanagement\inspection of incoming goods\_Wareneingangskontrolle\WEK\Externe Vermessung von Bauteilen\Eumetron\Messdaten\...\"
'Columns("C:Q").ClearContents
ThisWorkbook.Worksheets("Tabelle1").UsedRange.ClearContents
For intA = 1 To Anz
 F = (Timer - T) / intA
 Application.StatusBar = intA & " / " & Anz & " Restzeit: " & Format((Anz - intA) \* F, "0 sec")
 strFile = Range("A" & intA).Value
 Call Kopieren(strFile, intA)
Next intA
hell:
If Err.Number 0 Then MsgBox Err.Number & vbCr & Err.Description
MsgBox "done in " & Timer - T & " seconds"
Application.StatusBar = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function Kopieren(ByVal strFile As String, ByVal intA As Integer)
With ThisWorkbook.Worksheets("Tabelle1")
 Workbooks.Open Filename:=strFile
 ActiveWorkbook.Worksheets(1).Range("A11:AN11,A16:AN16").Copy
 .Range("D" & (intA - 1) \* 4 + 1).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 ActiveWorkbook.Close savechanges:=True
End With
End Function

Gruß
Reinhard

#5

Hallo Reinhard,

also erst mal vielen Danke das du dir so einen Stress gibst. Jetzt gehts los:smiley:
Wenn ich dein Makro ausführen will kommt diese Fehlermeldung:
http://s1.directupload.net/file/d/2460/kzt5vfi4_jpg.htm

Am besten wäre es natürlich wenn ich einfach zwei Buttons hätte (Button 1: 3Messdaten -Button 2: 4 Messdaten)und Excel den ganzen Ordner einfach abarbeitet. Aber ich habe gehört dass das Excel gar nicht kann, also so Automatisch und das überschreitet auch bei weitem meine fähigkeiten in VBA^^.

Gruß
Christian

#6

Hallo Reinhard,

also erst mal vielen Danke das du dir so einen Stress gibst. Jetzt gehts los:smiley:
Wenn ich dein Makro ausführen will kommt diese Fehlermeldung:
http://s1.directupload.net/file/d/2460/kzt5vfi4_jpg.htm

Am besten wäre es natürlich wenn ich einfach zwei Buttons hätte (Button 1: 3Messdaten -Button 2: 4 Messdaten)und Excel den ganzen Ordner einfach abarbeitet. Aber ich habe gehört dass das Excel gar nicht kann, also so Automatisch und das überschreitet auch bei weitem meine fähigkeiten in VBA^^.

Gruß
Christian