Makro funktioniert einmal aber nicht im Loop
12.12.2017 21:26:48
Markus
ich habe zum ersten Mal probiert, Daten per VBA aus einer Text-Datei in Excel zu importieren.
Mein Makro funktioniert ohne Probleme, wenn ich es für ein einzelnes Blatt laufen lasse, möchte ich aber das gleiche Makro per Loop für 4 (oder mehr) Blätter laufen lassen, funktioniert es immer nur für das jeweils erste (ich erhalte keine Fehlermeldung).
Wenn ich den Loop mit der Zeile "For wsCount = 10 To 13" beginne, funktioniert es nur für Blatt 10.
Wenn ich den Loop mit der Zeile "For wsCount = 11 To 13" beginne, funktioniert es nur für Blatt 11. usw.
Da der Code ansonsten funktioniert, vermute ich, ich verwende irgendeine falsche Referenz in Bezug auf die Variable wsCount oder mir fehlt ein Schritt am Anfang oder Ende des Loops.
Ich vermute, der Fehler bzw. falsche Bezug ist in den Bereichen "Set qt..." oder "With qt...".
Kann mir jemand damit weiterhelfen ?
Mein Code:
Option Explicit
Sub update_all()
Dim wsCount As Long, lngCalc As Long
Dim str_adr As String, co_na As String
Dim qt As QueryTable
Dim co As WorkbookConnection, i As Long, lz As Long
Dim booUSS As Boolean, strDec As String, strTho As String
' lngCalc = Application.Calculation
' Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
For wsCount = 10 To 13
With Worksheets(wsCount)
.Cells.ClearContents
.Cells.NumberFormat = "General"
booUSS = Application.UseSystemSeparators
strDec = Application.DecimalSeparator
strTho = Application.ThousandsSeparator
With Application
.UseSystemSeparators = False
.DecimalSeparator = "."
.ThousandsSeparator = ","
End With
On Error GoTo Errhandler
Select Case wsCount
Case 10
str_adr = "\\...\import1.txt"
Case 11
str_adr = "\\...\import2.txt"
Case 12
str_adr = "\\...\import3.txt"
Case 13
str_adr = "\\...\import4.txt"
End Select
Set qt = .QueryTables.Add(Connection:="TEXT;" & str_adr, Destination:=.Range("$A$1") _
)
With qt
.TextFileParseType = xlDelimited
.AdjustColumnWidth = False
.TextFilePlatform = 65001 'utf-8
.TextFileCommaDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileTabDelimiter = True
.Refresh BackgroundQuery:=False
End With
For Each co In ThisWorkbook.Connections
co_na = co.Name
ThisWorkbook.Connections(co_na).Delete
Next co
.Cells.QueryTable.Delete
With Application
.UseSystemSeparators = booUSS
.DecimalSeparator = strDec
.ThousandsSeparator = strTho
End With
Exit Sub:
Errhandler:
With Application
.UseSystemSeparators = booUSS
.DecimalSeparator = strDec
.ThousandsSeparator = strTho
End With
End With
Next wsCount
' Application.Calculation = lngCalc
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Markus