Office: Eine mit x markierte Zelle soll bestimmte Spalten aus der gleichen Zeile kopieren

Hallo liebe Forum-Mitglieder!

Ich habe folgendes Problem, was ich euch schildern möchte:

Ich möchte eine mit "x" markierte Zelle, dass es genau diese Zeile nimmt und ganz bestimmt spalten in ein anderes Arbeitsblatt (in der gleichen Datei) in eine vordefinierte Zelle speichert. (auch in der gleichen Zeile)

Hier ein bisschen visuelles:



Mein Ansatz:

PHP:

Code:

Private Sub import2_Click() 

Dim db As Worksheet, DbRD As Worksheet 
Dim x As Long, y As Long, lngZeilen As Long 

Set db = Worksheets("DB_1") 
Set DbRD = Worksheets("tab_pt") 

lngZeilen = db.Cells(db.Rows.Count, 2).End(xlUp).Row 

For y = 1 To lngZeilen 
If db.Cells(y, 2).Value Like "x*" Then 
x = DbRD.Cells(Rows.Count, 2).End(xlUp).Row + 1 ' eventuell die 7 gegen eine Spalte wechseln, in der mit Sicherheit etwas drinsteht. 
'db.Rows(y).Copy DbRD.Rows(x) 
'db = Source und DbRD = Destination 
ThisWorkbook.Sheets("DB_1").Cells(y, 9).Copy Destination:=ThisWorkbook.Sheets("tab_pt").Cells(x, 21) 
End If 
Next y 

End Sub 


Aber er geht nicht durch die Schleife, ganz zu schweigen überträgt er den Zellinhalt.
Meine Nomenklatur db = Database (Alle Informationen in dem Arbeitsblatt)

Kann mir jemand helfen?

Das wäre super nett!

Viele Grüße

 

Hallo,

da es einige Unterschiede zwischen den Spaltennummern im Makro und den Spaltennummern in der Abbildung gibt, habe ich mich im folgenden Makro an die Inhalte der Abbildung gehalten:

Code:

Private Sub Import2_Click()
  '
  Dim Db As Worksheet, DbRD As Worksheet
  Dim Db_Zl As Long, DbRD_Zl As Long
  Dim Db_Zl_Lzt As Long
  '
  Set Db = Worksheets("DB_1")
  Set DbRD = Worksheets("tab_pt")
  '
  'Letzte verwendete Zeile in Spalte 1 des Arbeitsblattes "DB_1"
  Db_Zl_Lzt = Db.Cells(Db.Rows.Count, 1).End(xlUp).Row
  'Man könnte dafür auch folgende Formel verwenden:
  'Db_Zl_Lzt = Db.UsedRange.Rows.Count
  '  
  'Momentane Ausgabezeile im Arbeitsblatt "tab_pt"
  DbRD_Zl = 0
  '
  'Durchlaufe alle verwendeten Zeilen des Arbeitsblattes "DB_1"
  For Db_Zl = 1 To Db_Zl_Lzt
    'Überprüfe, ob der Zellwert in Spalte 2 von "DB_1" mit "x" beginnt
    If Db.Cells(Db_Zl, 2).Value Like "x*" Then
      'Erhöhe Ausgabezeilennummer im Arbeitsblatt "tab_pt" um 1
      DbRD_Zl = DbRD_Zl + 1
      'Kopiere Zelle aus Spalte 3 in "DB_1" nach Spalte 3 in "tab_pt"
      Db.Cells(Db_Zl, 3).Copy Destination:=DbRD.Cells(DbRD_Zl, 3)
      'Kopiere Zelle aus Spalte 5 in "DB_1" nach Spalte 9 in "tab_pt"
      Db.Cells(Db_Zl, 5).Copy Destination:=DbRD.Cells(DbRD_Zl, 9)
    End If
  Next Db_Zl
  '
End Sub

 

Wow, das war genau das, was ich gesucht habe. Vielen vielen Dank für deinen Ansatz! Ich habe es modifiziert und es funktioniert prima.

Danke noch einmal!

Viele Grüße