Wert in Spalte finden und ganze Zeile übertragen VBA

[BadHabiit]

Hallo zusammen,

ich habe eine Exceldatei als Bestellformular und 2 Datenbanken in der die Bestellungen abhängig vom Lagerort eingehen sollen.
Bei klick auf Bestellbutton soll je nach Lagerort die Zelle in die jeweilige Datenbank geschrieben werden.

Das ganze funktioniert bereits mit einer IF Abfrage die ich aber für jede Zelle einzeln abfragen muss.

Hier der Code

Code:

'Empfang
If Range("N3").Value = "Empfang" Then

    Application.ScreenUpdating = False
    Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
    Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Empfang.xlsx").Sheets("Bestellungen") ' anpassen
    With shZiel
        lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
        .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A3:M3").Value
        ' ... usw.

    End With
   

End If

'Lager
If Range("N3").Value = "Lager" Then

    Application.ScreenUpdating = False
    Set shQuelle = ThisWorkbook.Sheets("Bestellen")
    Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Lager.xlsx").Sheets("Bestellungen")
    With shZiel
        lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
        .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A3:M3").Value
        ' ... usw.

    End With
   

End If
'Zeile 3 Ende
End If

Da ich viele Bestellungen habe wird der Code ziemlich lange, da ich jede Zeile einzeln Abfragen muss.
Kennt jemand eine einfachere Variante?
(Wenn in Spalte N "Lager" dann übertrage Zeile A:M in die Datei "Datenbank Lager" Sheet "Bestellungen" in die erste freie Zeile der Spalte A.
Wenn in Spalte N "Empfang" dann mach das gleiche nur in die Datei "Datenbank Empfang"
Danke schonmal im Voraus :)

[IchBinIch]

Hi,

steht in Zelle N3 nur Lager oder Empfang?

Gruß 
Ich

[Kuwer]

Hallo,

so z.B.:

  Application.ScreenUpdating = False
 Set shQuelle = ThisWorkbook.Sheets("Bestellen")
 Select Case Range("N3").Value
   Case "Empfang"
     Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Empfang.xlsx").Sheets("Bestellungen")
   Case "Lager"
     Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Lager.xlsx").Sheets("Bestellungen")
   ' ... usw.
 End Select
 With shZiel
   lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Cells(lngZeile, 1).Resize(1, 13).Value = shQuelle.Range("A3:M3").Value
 End With

oder wenn Dateiname exakt den Suchbegriff enthält:

  Application.ScreenUpdating = False
 Set shQuelle = ThisWorkbook.Sheets("Bestellen")
 Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank " & Range("N3").Value & ".xlsx").Sheets("Bestellungen")
 With shZiel
   lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Cells(lngZeile, 1).Resize(1, 13).Value = shQuelle.Range("A3:M3").Value
 End With

Gruß Uwe

[BadHabiit]

Danke für die Antworten. 
Der Code war nur ein kleiner ausschnitt.

Ich suche eine kurze Alternative zu meinem Code das ich nicht jede Zeile abfragen muss. 

Code:

'Empfang
If Range("N3").Value = "Empfang" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Empfang.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A3:M3").Value
Ende If

'Lager
If Range("N3").Value = "Lager" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Lager.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A3:M3").Value
Ende If

'Empfang
If Range("N4
").Value = "Empfang" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Empfang.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A4:M4").Value

Ende If

'Lager
If Range("N4").Value = "Lager" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Lager.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A4:M4").Value


Ende If

'Empfang
If Range("N5
").Value = "Empfang" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Empfang.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A5:M5").Value

Ende If

'Lager
If Range("N5").Value = "Lager" Then

   Application.ScreenUpdating = False
   Set shQuelle = ThisWorkbook.Sheets("Bestellen")   ' anpassen
   Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank Lager.xlsx").Sheets("Bestellungen") ' anpassen
   With shZiel
       lngZeile = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
       .Range("A" & lngZeile & ":M" & lngZeile) = shQuelle.Range("A5:M5").Value


Ende If

Usw. Bis Range("A1000:M1000")

Die Tabelle ist wie folgt aufgebaut:


           A                  B                 C               D                      E F...       N
1
2         Datum        Produkt     Stück        Name               usw...    Lagerort
3         18.09.16    Produkt 1   10 Stk.    Mustername                   Lager
4...
...
1000   18.09.16   Produkt 2    25 Stk.    Mustername                  Empfang


Sobald man den Bestellbutton klickt gehen alle Zeilen wo in Spalte M Empfang steht in die "Datenbank Empfang" und bei Lager in die  "Datenbank Lager".
(Jeweils in die letzte freie Zeile)

[Kuwer]

Hallo,

Sub Uebertrag()
 Dim rngZ As Range
 Dim shQuelle As Worksheet
 Dim shZiel As Worksheet
 Set shQuelle = ThisWorkbook.Sheets("Bestellen")
 Application.ScreenUpdating = False
 For Each rngZ In shQuelle.Range("N3:N1000")
   Select Case rngZ.Value
     Case "Empfang", "Lager"
       Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank " & rngZ.Value & ".xlsx").Sheets("Bestellungen")
       lngZeile = shZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1
       shZiel.Cells(lngZeile, 1).Resize(1, 13).Value = rngZ.Offset(0, -13).Resize(1, 13).Value
       Set shZiel = Nothing
   End Select
 Next rngZ
End Sub

Gruß Uwe

[BadHabiit]

Perfekt Danke :)

Jetzt will ich noch das in Spalte O das Datum eingetragen wird wenn in Spalte D etwas steht, ohne das ich jede Zeile einzeln abfragen muss.

If Range("D3").Value <> "" Then Range("O3").Value = Date
If Range("D4").Value <> "" Then Range("O4").Value = Date
If Range("D5").Value <> "" Then Range("O5").Value = Date
If Range("D6").Value <> "" Then Range("O6").Value = Date
If Range("D7").Value <> "" Then Range("O7").Value = Date
If Range("D8").Value <> "" Then Range("O8").Value = Date
If Range("D9").Value <> "" Then Range("O9").Value = Date
...
...
If Range("D1000").Value <> "" Then Range("O1000").Value = Date


Danke schonmal :)

[Kuwer]

Hallo,

Sub Uebertrag()
 Dim rngZ As Range
 Dim shQuelle As Worksheet
 Dim shZiel As Worksheet
 Set shQuelle = ThisWorkbook.Sheets("Bestellen")
 Application.ScreenUpdating = False
 For Each rngZ In shQuelle.Range("N3:N1000")
   Select Case rngZ.Value
     Case "Empfang", "Lager"
       Set shZiel = GetObject("U:\Empfang\02_Transfer\Produktmuster\Muster Datenbanken\Datenbank " & rngZ.Value & ".xlsx").Sheets("Bestellungen")
       lngzeile = shZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1
       shZiel.Cells(lngzeile, 1).Resize(1, 13).Value = rngZ.Offset(0, -13).Resize(1, 13).Value
       If Len(shZiel.Cells(lngzeile, 4)) Then shZiel.Cells(lngzeile, 14).Value = Date
       Set shZiel = Nothing
   End Select
 Next rngZ
End Sub

Gruß Uwe

[BadHabiit]

Wie lautet der Code wenn das Datum in die gleiche Arbeitsmappe geschrieben werden soll?

[Kuwer]

Wie lautet der Code wenn das Datum in die gleiche Arbeitsmappe geschrieben werden soll?

keine Ahnung.

[schauan]

Hallöchen,

schaue Dir mal an, wie die Quelle programmiert ist. Das Ziel programmierst Du dann entsprechend.