Anzeige
Archiv - Navigation
416to420
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
416to420
416to420
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Code vermehren / wiederholen

Code vermehren / wiederholen
Erich
Hallo EXCEL-Freunde,
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Code vermehren / wiederholen
Josef
Hallo Erich!
Ungetestet!
Option Explicit

Sub vermehren()
Dim intC As Integer
Worksheets(myName1).Activate
For intC = 0 To 9 '####Start Schleife
Set rng = Range(Cells(1, letzteSpalte + intC), Cells(myZeile, letzteSpalte + intC))
lngR = rng.Rows.Count
For Each Zelle In rng
For lngC = 1 To lngR
With Zelle
If .Value <> "" And Cells(rng(lngC).Row, neueSpalte + intC) <> "Original" _
And Cells(rng(lngC).Row, neueSpalte + intC) <> "Duplikat" Then
If Zelle = rng(lngC) Then
Cells(rng(lngC).Row, neueSpalte + intC) = "Duplikat"
Cells(.Row, neueSpalte + intC) = "Original"
End If
End If
End With
Next
Next
Next '####Ende Schleife
'_________________________________________________
' Code 2

Dim strSearch As String, myName2 As String
Dim lngE As Long
Dim intC As Integer
'####
myName2 = "Netzstruktur"
Sheets(myName2).Cells(1, 2) = "Pfad 1"
For intC = 0 To 9 '####Start Schleife
lngE = IIf(IsEmpty(Sheets(myName2).Cells(65563, intC + 2)), _
Sheets(myName2).Cells(65563, intC + 2).End(xlUp).Row + 1, 65536)
'####
strSearch = "Original"
For i = 2 To Worksheets(myName1).Cells(65536, neueSpalte + intC).End(xlUp).Row
If ActiveSheet.Cells(i, neueSpalte + intC) = strSearch Then
'####
Sheets(myName2).Cells(lngE, 2) = Worksheets(myName1).Cells(i, letzteSpalte + intC)
lngE = lngE + 1
'####
End If
Next
Next '####Ende Schleife
End Sub

Gruß Sepp
Anzeige
DANKE - Sepp! Super, das wars - o.T.!!
Erich
.
Danke für die Rückmeldung! o.T.
25.04.2004 18:56:53
Josef
Gruß Sepp

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige