Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bei zwei Kriterien eine Zelle Kopieren

Bei zwei Kriterien eine Zelle Kopieren
17.03.2016 10:46:35
Felix
Hallo,
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
Ich hoffe, dass mir jemand helfen kann, oder mich zumindest in die Richtung eines anderen Ansatzes schieben kann.
Danke Schonmal!

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bei zwei Kriterien eine Zelle Kopieren
17.03.2016 10:51:24
selli
hallo felix,
da werden doch schon 2 kriterien abgefragt (steht sogar als kommentar darüber)
ein weiteres kannst du nach gleichem schema hinzufügen.
"If" ist englisch und heisst "wenn" - da passiert die abfrage.
wo genau ist jetzt dein problem?
gruß
selli

AW: Bei zwei Kriterien eine Zelle Kopieren
17.03.2016 11:00:21
Felix
Hi,
danke, dass du dich um mich kümmerst:-)
Dann Vorweg, Mea Culpa, ich dachte, dass die Fehler wahrscheinlich offensichtlich sind. Das Problem ist, dass sich etwas tut, also Excel arbeitet, aber ohne das gewünschte Ergebnis zu Produzieren.
In der Zieldatei erscheint leider nichts. Allerdings verstehe ich nicht recht warum.
Grüße,
Felix

Anzeige
AW: Bei zwei Kriterien eine Zelle Kopieren
17.03.2016 12:15:51
selli
hallo felix,
da haben noch referenzierungen gefehlt und die zeile dea copierens war verdreht, d.h. erst ziel angeben, dann die quelle.
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
Dim letzte
'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(wksquelle.Cells(2, 1), wksquelle.Cells(letzte, 1))
If wksquelle.Cells(rng.Row, 3) = "ja" And wksquelle.Cells(rng.Row, 4) = "x" Then
wksziel.Cells(rng.Row + 50, 11) = wksquelle.Cells(rng.Row, 4)
End If
Next rng
End Sub
gruß
selli

Anzeige
eingeschlichener fehler
17.03.2016 12:18:09
selli
hallo felix,
sorry, jetzt hat sich auch bei mir noch ein fehler eingeschlichen.
so:
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
letzte = wksquelle.Cells(wksquelle.Rows.Count, 2).End(xlUp).Row
For Each rng In wksquelle.Range(wksquelle.Cells(2, 1), wksquelle.Cells(letzte, 1))
If wksquelle.Cells(rng.Row, 3) = "ja" And wksquelle.Cells(rng.Row, 4) = "x" Then
wksziel.Cells(rng.Row + 50, 11) = wksquelle.Cells(rng.Row, 4)
End If
Next rng
End Sub

gruß
selli

Anzeige
AW: eingeschlichener fehler
17.03.2016 12:37:17
Felix
Danke dir!
Ich probiere das gleich aus und melde mich natürlich.

Denkfehler von mir
17.03.2016 14:04:09
mir
Hey Selli,
Das Funktioniert, musste nur noch die Zeile
Dim letzte as Long
ergänzen.
Jetzt hat sich natürlich ein Denkfehler gezeigt. Die Kopierten werte, werden in der Zieldatei entsprechend dem Code in dieselbe Zeile wie in der Quelldatei gespeichert. Gibt es eine einfache Methode die Werte ab festgelegter Zeile in eine Spalte untereinander zu schreiben?

AW: Denkfehler von mir
17.03.2016 14:19:36
mir
hallo felix,
das dann so:
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
Dim letzte As Long
Dim neueZeile
'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
letzte = wksquelle.Cells(wksquelle.Rows.Count, 2).End(xlUp).Row
neueZeile = 1 'hier eintragen in welcher zeile begonnenwerden soll
For Each rng In wksquelle.Range(wksquelle.Cells(2, 1), wksquelle.Cells(letzte, 1))
If wksquelle.Cells(rng.Row, 3) = "ja" And wksquelle.Cells(rng.Row, 4) = "x" Then
wksziel.Cells(neueZeile, 11) = wksquelle.Cells(rng.Row, 4)
neueZeile = neueZeile + 1
End If
Next rng
End Sub

gruß
selli

Anzeige
Perfekt Selli
17.03.2016 15:24:23
Felix
Saved the Day!
Vielen Dank...aber ich fürchte das war erst der Anfang meiner unbeholfenen Reise.

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige