VBA Schleife & If.. Then Next

Sub AnAlleVersenden

Sub AnAlleVersenden()
'W?hle Spalte AD aus und erstelle eine ?berschrift f?r die Spalte
Sheets("Liste").Select
Range("AD1").Select
ActiveCell.FormulaR1C1 = "Controller"
Range("AD1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8813846
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
'F?ge XVerweis hinzu
Range("AD2").Select
ActiveCell.FormulaR1C1 = _
"=XLOOKUP(RC[-29],Zuordnung!R7C3:R168C3,Zuordnung!R7C1:R168C1)"
Range("AD2").Select
Selection.AutoFill Destination:=Range("AD2:AD15236")
Range("AD2:AD15236").Select
Dim j As Integer
For j = 7 To 8
Dim i As Integer
For i = 7 To 8
ThisWorkbook.Worksheets("Zuordnung").Activate
'Hier startet das Problem
If Sheets("Zuordnung").Cells(i, 1).Value = _
Sheets("Zuordnung").Range(Cells(6, 1), Cells(i - 1, 1)).Value Then
Else: GoTo Start
End If
Next i
Start:
'Hier endet das Problem.


Ich habe in der ersten Spalte Namen stehen (doppelt, dreifach,..) Er erstellt zwei Dateien    _
_
_
mit „Name1“ obwohl er erkennen müsste, dass er „Name1“ schon hatte und zum nächsten Name (i)  _
springen sollte.


'Das Tabellenblatt aktivieren

ThisWorkbook.Worksheets("Liste").Activate

'FilterEinstellungen auf null setzen

ActiveSheet.Columns("A:AD").AutoFilter

'Filter w?hlen - Referenz Zuordnung Zelle A2

ActiveSheet.Columns("A:AD").AutoFilter 30, "=" & Worksheets("Zuordnung").Cells(j, 1).Value

'Neues Tabellenblatt hinzuf?gen

'Tabelle leeren

ThisWorkbook.Worksheets("Exportliste").Cells.Clear

'Informationen kopieren

ActiveSheet.Range("A1:AC20000").Copy Destination:=ThisWorkbook.Worksheets(" _

Exportliste").Range("A1")

ThisWorkbook.Worksheets("Exportliste").Activate

'Exportliste versenden per Outlook an Controller

Dim DateiNameA As String

Dim NameDatei As String

DateiNameA = Worksheets("Zuordnung").Range("D3") & Worksheets("Zuordnung").Cells(j, 1) & " " _

_

_

& Worksheets("Zuordnung").Range("D5") & ".xlsx"

NameDatei = DateiNameA

Sheets("Exportliste").Copy

With ActiveWorkbook

.SaveAs filename:=DateiNameA

.Close

End With

Dim OutlookApp As Object

Dim OutlookMailItem As Object

Dim myAttachments As Object

Set OutlookApp = CreateObject("Outlook.Application")

Set OutlookMailItem = OutlookApp.CreateItem(0)

Set myAttachments = OutlookMailItem.Attachments

With OutlookMailItem

.To = Worksheets("Zuordnung").Cells(j, 2).Value

.Subject = Worksheets("Zuordnung").Range("D5").Value

.Body = Worksheets("Zuordnung").Range("D1").Value

.Attachments.Add NameDatei

.Display 'Hier Display durch Send ersetzen!!

End With

Set OutlookApp = Nothing

Set OutlookMailItem = Nothing

Next j

MsgBox "Die Email wurde an an alle Mitarbeiter versandt."

End Sub