Bei zwei Kriterien eine Zelle Kopieren
17.03.2016 10:46:35
Felix
ich bin noch recht neu im VBA und verstehe die Zusammenhänge bis jetzt nur schwer.
Ich habe die Aufgabe aus einer Datei bei zwei bzw. drei zutreffenden Kriterien in einer Zeile den entsprechenden Wert in eine andere Mappe zu übertragen.
Mein Ansatz sieht bis jetzt so aus:
Option Explicit
Sub SammelnAusInfopool()
Application.ScreenUpdating = True
Dim fd As FileDialog
Dim FileName As String
Dim wbZiel As Workbook, wbquelle As Workbook
Dim wksziel As Worksheet, wksquelle As Worksheet
Dim rng As Range
'Datei aus der Import wird öffnen
Set fd = Application.FileDialog(msoFileDialogOpen)
Dim FileChosen As Integer
FileChosen = fd.Show
fd.Title = "Infopool auswählen"
fd.Filters.Add "Infopool", "*.xls*", 1
fd.ButtonName = "Auswählen"
fd.InitialFileName = "Speicherort"
If FileChosen -1 Then
MsgBox "Aktion abgebrochen"
Else
FileName = fd.SelectedItems(1)
Set wbquelle = Workbooks.Open(FileName)
End If
Set wbZiel = ThisWorkbook
Set wksziel = wbZiel.Worksheets(1)
Set wksquelle = wbquelle.Worksheets(3)
On Error GoTo Fehler
'Filter löschen
wksquelle.ShowAllData
'entsprechende Spalten auf Kriterien Prüfen und dann Kopieren
For Each rng In wksquelle.Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlDown))
If wksquelle.Cells(rng.Row, 3) = "ja" And wksquelle.Cells(rng.Row, 4) = "x" Then
wksquelle.Cells(rng.Row, 4).Value = wksziel.Cells(rng.Row + 50, 11).Value
End If
Next rng
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Ein Fehler ist aufgetreten, Ergebnisse Kontrollieren!"
End Select
End With
End Sub
Danke Schonmal!