VBA Schleife Zellen auswählen und selektieren
08.06.2015 14:34:45
Andreas
trotz langem Suchen habe ich keine Lösung gefunden. Ich hoffe Ihr könnt mich helfen.
Folgende Ausgangssituation:
- Mappe Makro befindet sich nur ein Button mit meiner Makro.
- In der Mappe Daten befinden sich alle Informationen die selektiert und kopiert werden sollen.
- Mappe Namen beinhaltet in Spalte A die Suchkriterien für die Mappe Daten.
Ich benötige eine Schleife die automatisch die Zelle A2 aus der Mappe Daten auswählt und anschließend den Wert als Suchkriterium in Tabelle1 (Mappe Daten) einsetzt.
Das daraus resultierende Ergebnis soll anschließend in eine neue Excel Datei kopiert, abspeichert und per Mail versendet werden.
Wenn dies erfolgt ist soll das Prozedere erneut, allerdings mit A3, starten. Solange bis zur ersten leeren Zelle in Spalte A.
Anbei findet Ihr meine ersten Versuche. Das Problem liegt bei mir darin, dass ich nicht den Sprung in die nächste Zelle schaffe und dieses als Suchkriterium zu verwenden.
Das speichern und versenden klappt super. Nur das Suchen nicht.
Sub Anhang()
' Anhang Makro
betreff = Worksheets("Daten").Range("B3").Value
'Betreff für die Mail hinterlegen
betreff1 = Range("B7").Value
'Betreff1 für die Mail hinterlegen
empfaenger = Worksheets("Daten").Range("W2").Value
'Empfänger für die Mail hinterlegen
'A12 = Worksheets("Daten").Range("A2").Value
Dim Speicherpfad As String
Speicherpfad = "\\bosch.com\dfsrb\DfsDE\Loc\Sw\bank\C:\temp"
AnzZeilen = ActiveSheet.UsedRange.Rows.Count
'i = Worksheets("Daten").Range("B2").Value
Dim lAnzahl As String
Anf:
lAnzahl = InputBox("Wie oft soll das Makro laufen ?", , 3)
If lAnzahl = "" Then Exit Sub
'Prüfen ob eine Zahl eingegeben wurde
If IsNumeric(lAnzahl) Then
For i = 1 To CLng(lAnzahl)
Sheets("Namen").Select
Range("A2").Select
AnzZeilen = ActiveSheet.UsedRange.Rows.Count
Selection.Copy
Sheets("Daten").Select
ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1, Criteria1:=Worksheets("Namen" _
).Range("A2"), Operator:=xlAnd
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(Array("Tabelle2", "Tabelle3")).Delete
Application.DisplayAlerts = True
'Speichern
Const LW = "C:\"
Const Pfad = "\\bosch.com\dfsrb\DfsDE\Loc\Sw\bank\C:\temp"
ChDrive LW
ChDir _
"C:\temp"
ActiveWorkbook.SaveAs Filename:=Range("A2") & "-" & "Offene_WF" & " - " & Date & " - " & _
Format(Time, "hh-mm-ss") & ".xlsm" _
, FileFormat:=52, CreateBackup:=False
'Per Mail versenden
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
AWS = ActiveWorkbook.FullName
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = empfaenger
.Subject = "Offene WF -" & "/ " & Date
.attachments.Add AWS
.Body = "Hallo," & vbCrLf & "anbei finden
." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & " _
Mit freundlichen Grüßen" & vbCrLf & Range("B12")
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
SendKeys "%s", True
SendKeys "^{ENTER}", True
Set objEMail = Nothing
ActiveWorkbook.Close SaveChanges:=False
Next
Else
MsgBox "Bitte ein Zahl eingeben !", vbInformation
GoTo Anf
End If
End Sub