AW: Zelleninhalt suchen und verschieben
28.11.2014 08:44:16
fcs
Hallo Christian,
hier der angepasste Code.
Wenn die Bläter immer die gleiche Reihenfolge haben, dann kann man auch mit der Index-Nr. arbeiten
Gruß
Franz
Private Sub CommandButton1_Click()
Dim wks, intSheet
Dim arrwks1() As Worksheet, arrwks2() As Worksheet
Dim arrZeile1() As Long, arrZeile2() As Long
Dim int1 As Integer, int2 As Integer
Dim varTB_1, varTB_2, varTB_3
Dim arrData, Zeile As Long, ZeileL As Long
'Eingaben in Textboxen prüfen und Werte in Variablen übernehmen
With Me.TextBox1
If .Value = "" Then
MsgBox "Bitte erst Nr. Auftrag eingeben!"
Exit Sub
Else
varTB_1 = IIf(IsNumeric(.Value), Val(.Value), .Value)
End If
End With
With Me.TextBox2
If .Value = "" Then
MsgBox "Bitte erst Nr. für Maschine eingeben!"
Exit Sub
Else
varTB_2 = IIf(IsNumeric(.Value), Val(.Value), .Value)
End If
End With
With Me.TextBox3
If .Value = "" Then
MsgBox "Bitte erst Datum eingeben!"
Exit Sub
Else
If IsDate(.Value) Then
varTB_3 = CDate(.Value)
Else
MsgBox "Eingabe für Datum ist kein gültiger Datumswert"
End If
End If
End With
' Werte in Tabelle2 bis Tabelle8 suchen
For intSheet = 2 To 10 Step 2
' Set wks = ActiveWorkbook.Sheets("Tabelle" & Format(intSheet, "0"))
Set wks = ActiveWorkbook.Sheets(intSheet)
With wks
'letzte Zeile mit Daten in Spalte A und C
ZeileL = Application.WorksheetFunction.Max( _
.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(.Rows.Count, 3).End(xlUp).Row)
'Daten aus Spalten A:C in Array einlesen
arrData = .Range(.Cells(1, 1), .Cells(ZeileL, 3))
'Werte vergleichen und Treffer-Blatt/Zeile merken
For Zeile = 3 To ZeileL
If arrData(Zeile, 2) = varTB_2 Then 'Maschine vergleichen
If arrData(Zeile, 3) = varTB_1 Then 'Auftrag vergleichen
int1 = int1 + 1
ReDim Preserve arrwks1(1 To int1), arrZeile1(1 To int1)
arrZeile1(int1) = Zeile
Set arrwks1(int1) = wks
End If
If arrData(Zeile, 1) = varTB_3 _
And arrData(Zeile, 3) = "" _
And int2 = 0 Then 'Datum vergleichen, bei vorhandenem Auftrag _
überspringen, nur eine Zeile merken
int2 = int2 + 1
ReDim Preserve arrwks2(1 To int2), arrZeile2(1 To int2)
arrZeile2(int2) = Zeile
Set arrwks2(int2) = wks
End If
End If
Next Zeile
End With
Next intSheet
If int1 = 0 Or int2 = 0 Then
If int1 = 0 Then
MsgBox "Auftrag " & varTB_1 & " zu Maschine " & varTB_2 & " nicht gefunden!"
End If
If int2 = 0 Then
MsgBox "Datum " & varTB_3 & " zu Maschine " & varTB_2 & " nicht gefunden!"
End If
Else
'Werte in gefundenen Zellen ersetzen
'Auftrag zu Maschine löschen
For Zeile = 1 To int1
arrwks1(Zeile).Cells(arrZeile1(Zeile), 3).ClearContents
Next
'Auftrag zu Maschine bei Datum eintragen
For Zeile = 1 To int2
arrwks2(Zeile).Cells(arrZeile2(Zeile), 3).Value = varTB_1
Next
' Unload Me 'Userform schliessen
End If
'Variablen zurücksetzen
Erase arrData, arrwks1, arrwks2, arrZeile1, arrZeile2
Set wks = Nothing
End Sub