Code vermehren / wiederholen
Erich
ich muss innerhalb der Ausführung über eine UserForm einen Codeteil mehrmals
verwenden, wobei sich jeweils die zu bearbeitenden Spalten ändern. Bevor ich
den nun 9 mal wiederhole, eine anfrage, ob man das automatisieren kann; habe
im Code versucht die notwendigen Änderungen zu beschreiben; eine Automatisierung
eines codes wäre auch schon hilfreich:
Option Explicit
Sub vermehren()
'_______________________________________________
' Code 1
Worksheets(myName1).Activate
Set rng = Range(Cells(1, letzteSpalte), Cells(myZeile, letzteSpalte))
lngR = rng.Rows.Count
For Each Zelle In rng
For lngC = 1 To lngR
With Zelle
If .Value <> "" And Cells(rng(lngC).Row, neueSpalte) <> "Original" _
And Cells(rng(lngC).Row, neueSpalte) <> "Duplikat" Then
If Zelle = rng(lngC) Then
Cells(rng(lngC).Row, neueSpalte) = "Duplikat"
Cells(.Row, neueSpalte) = "Original"
End If
End If
End With
Next
Next
' 2. Runde
' Änderung: letzteSpalte + 1; neueSpalte +1
Set rng = Range(Cells(1, letzteSpalte + 1), Cells(myZeile, letzteSpalte + 1))
lngR = rng.Rows.Count
For Each Zelle In rng
For lngC = 1 To lngR
With Zelle
If .Value <> "" And Cells(rng(lngC).Row, neueSpalte + 1) <> "Original" _
And Cells(rng(lngC).Row, neueSpalte + 1) <> "Duplikat" Then
If Zelle = rng(lngC) Then
Cells(rng(lngC).Row, neueSpalte + 1) = "Duplikat"
Cells(.Row, neueSpalte + 1) = "Original"
End If
End If
End With
Next
Next
'---> 9 Wiederholungen ?
'_________________________________________________
' Code 2
Dim strSearch As String, myName2 As String
'####
myName2 = "Netzstruktur"
Sheets(myName2).Cells(1, 2) = "Pfad 1"
Dim lngE As Long, lngE2 As Long
lngE = IIf(IsEmpty(Sheets(myName2).Range("B65536")), _
Sheets(myName2).Range("B65536").End(xlUp).Row + 1, 65536)
'####
strSearch = "Original"
For i = 2 To Worksheets(myName1).Cells(65536, neueSpalte).End(xlUp).Row
If ActiveSheet.Cells(i, neueSpalte) = strSearch Then
'####
Sheets(myName2).Cells(lngE, 2) = Worksheets(myName1).Cells(i, letzteSpalte)
lngE = lngE + 1
'####
End If
Next i
' 2. Runde
Sheets(myName2).Cells(1, 3) = "Pfad 2"
' Änderungen: Spalte B wird C; letzteSpalte + 1; neueSpalte + 1; lngE wird lngE2
lngE2 = IIf(IsEmpty(Sheets(myName2).Range("C65536")), _
Sheets(myName2).Range("C65536").End(xlUp).Row + 1, 65536)
'####
strSearch = "Original"
For i = 2 To Worksheets(myName1).Cells(65536, neueSpalte + 1).End(xlUp).Row
If ActiveSheet.Cells(i, neueSpalte + 1) = strSearch Then
'####
Sheets(myName2).Cells(lngE2, 3) = Worksheets(myName1).Cells(i, letzteSpalte + 1)
lngE2 = lngE2 + 1
'####
End If
Next i
' ---> 9 Wiederholungen ?
End Sub
Besten Dank für eine Hilfe!
mfg
Erich