AW: Do-Loop Schleife läuft ewig
10.05.2022 16:53:52
ChrisL
Hi Markus
Ich muss Rudi recht geben. Der Umfang sprengt auch meine Möglichkeiten. Trotz intensivem Studium bin ich nicht dahinter gekommen, was unter welcher Bedingung wohin kopiert werden muss.
Der Code benötigt m.E. eine Generalüberholung.
- Die Schleife läuft irgendwie ins Nirvana
- Es fehlt die Übersichtlichkeit, um sich als Aussenstehender sinnvoll einzubringen. Hierfür wäre das Eliminieren von Select/Activate ein erster Schritt und zudem handelt es sich dabei um einen Performance-Fresser.
https://www.herber.de/vbabasics/0009.html
Deine Eigeninitiative (Code-Vorschlag) finde ich trotzdem positiv. Ich habe mir darum die Zeit genommen, um dir mal ein grobes Raster (nicht perfekt, aber ein Anfang) für die Bedingungen zur Verfügung zu stellen. Der Copy-Befehl ist schon drin und Paste an richtiger Stelle müsste man noch einfügen. Hierfür wie angetönt kein Select verwenden sondern direkt referenzieren z.B.
wbZiel.Sheets("Input GC B08").Cells(7 + j + p, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sub Messdatenimport_B08()
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim Datenquelle As String
Dim Name As String
Dim Endung As String
Dim LetzteZeile As Long
Dim rngZelle As Range
Dim lngZeile As Long
'Inputbox zum Datei öffen
Name = InputBox("Geben Sie den Dateinamen an:", "Datenquelle", "Datei 2")
Datenquelle = "xxx"
Endung = ".xlsx"
Datenquelle = Datenquelle & Name & Endung
Workbooks.OpenText Filename:=Datenquelle
'Mappen an Variablen + Zoom
Set wbZiel = ThisWorkbook
Set wbQuelle = ActiveWorkbook
ActiveWindow.Zoom = 70
'Zeugs ausschalten
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wbQuelle.Worksheets("Tabelle1")
'Bearbeitung Messdatenarchiv B08
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
.Rows(1).AutoFilter
.Rows(1).AutoFilter Field:=43, Criteria1:=""
.Columns("AW:BA").Delete Shift:=xlToLeft
.Rows(4).Delete Shift:=xlUp
For Each rngZelle In .Range("AW2:BA" & LetzteZeile)
If Not IsEmpty(rngZelle) Then rngZelle = Replace(rngZelle.Text, ",", Application.DecimalSeparator) * 1
Next rngZelle
.Columns("AW:BA").NumberFormat = "0.000"
'µGC Daten kopieren
For lngZeile = 4 To LetzteZeile
If .Rows(lngZeile).EntireRow.Hidden = False Then
.Range(.Cells(lngZeile, 43), .Cells(lngZeile, 52)).Copy
If .Cells(lngZeile, 5) = 0 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 0 Then
ElseIf .Cells(lngZeile, 5) = 1 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 0 Then
' If wbZiel.Sheets("Input GC B08").Cells(30 + q + p, 8) = 0 Then
' Else
' End If
ElseIf .Cells(lngZeile, 5) = 1 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 0 Then
ElseIf .Cells(lngZeile, 5) = 0 And .Cells(lngZeile, 6) = 1 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 0 Then
ElseIf .Cells(lngZeile, 5) = 0 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 1 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 0 Then
ElseIf .Cells(lngZeile, 5) = 0 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 1 And .Cells(lngZeile, 27) = 0 Then
ElseIf .Cells(lngZeile, 5) = 0 And .Cells(lngZeile, 6) = 0 And .Cells(lngZeile, 13) = 0 And .Cells(lngZeile, 20) = 0 And .Cells(lngZeile, 27) = 1 Then
Else
'Sonderfall
End If
End If
Next lngZeile
End With
'Zeugs einschalten
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Ich hoffe dies hilft dir weiter.
cu
Chris