Do-Schleife kopiert meine Daten nicht
07.04.2022 10:29:47
weitschuetz
ich hab mal wieder Probleme mit einem gebastelten Makro. Dies soll verschiedene Zellen in ein zweites Formular kopieren nach bestimmten Vorgaben. Die Datenreihen wiederholen sich immer wieder und es ändert sich nur der Wert Cells(3 + i, 4), dieser steigt bei jeder Wiederholung um eins. In der Zelle, mit der diese vergliechen wird, ist einen Formel hinterlegt, welche den Wert aus einem anderen Tabellenblatt anzeigt (also z.B. "=Sheet1!A5" und Anzeige ist z.B. 3). Wenn ich das Makro starte, sprint es gleich von dem Do While Schritt auf Application.ScreenUpdating = True Schritt.
Option Explicit
Sub Messdatenimport_B08()
Application.ScreenUpdating = False
Dim Datenquelle2 As String
Dim Name As String
Dim Endung As String
Dim i As Long
Dim j As Long
Dim q As Long
Dim w As Long
Dim e As Long
Dim r As Long
Dim t As Long
Dim z As Long
Name = _
InputBox("Geben Sie den Dateinamen an:", "Datenquelle", "B08_MesswertArchiv_2022_3_24_8_9_43")
Endung = ".xlsx"
Datenquelle2 = Name & Endung
i = 1
Do While Cells(3 + i, 4) ThisWorkbook.Sheets("Input GC B08").Cells(5, 1)
'Prüfgas
If Rows(3 + i).EntireRow.Hidden = False Then
If Cells(3 + i, 5) = 0 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(7 + j, 2).Select
j = j + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Eingangsmessung vor Reaktoren
If Cells(3 + i, 5) = 1 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 0 And ThisWorkbook.Sheets("Input GC B08").Cells(30 + q, 8) = 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(30 + q, 2).Select
q = q + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Eingangsmessung nach Reaktoren
If Cells(3 + i, 5) = 1 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 0 And ThisWorkbook.Sheets("Input GC B08").Cells(30, 8) 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(110 + z, 2).Select
z = z + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Reaktor G
If Cells(3 + i, 5) = 0 And Cells(3 + i, 6) = 1 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(45 + w, 2).Select
w = w + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Reaktor H
If Cells(3 + i, 5) = 0 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 1 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(61 + t, 2).Select
t = t + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Reaktor I
If Cells(3 + i, 5) = 0 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 1 And Cells(3 + i, 27) = 0 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(77 + e, 2).Select
e = e + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
Else
'Reaktor J
If Cells(3 + i, 5) = 0 And Cells(3 + i, 6) = 0 And Cells(3 + i, 13) = 0 And Cells(3 + i, 20) = 0 And Cells(3 + i, 27) = 1 Then
Range(Cells(3 + i, 43), Cells(3 + i, 52)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input GC B08").Select
Cells(93 + r, 2).Select
r = r + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(Datenquelle2).Activate
End If
End If
End If
End If
End If
End If
End If
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub