VBA Schleife & If.. Then Next
20.11.2020 10:35:37
viktor0000000000
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