Kopiere bestimmte Zellen anhand eines Kriteriums in Blätter mit demselben Label wie die Kriterien in einer anderen Arbeitsmappe.

Question

Ich versuche, einen Code für die folgende Aufgabe zu schreiben, aber ich habe ein ganzes Stück gekämpft. Ich habe 2 Arbeitsmappen, wb1 und wb2. wb1 hat eine Tabelle mit einer Liste von Namen in Spalte A, dann hat Spalte B-V die Daten, die ich auf das Blatt mit dem gleichen Namen wie in Spalte A, aber in einem anderen Buch (wb2) kopieren möchte. Der Ort, an den es eingefügt wird, hängt auch von einem anderen Kriterium auf dem Zielblatt in wb2 ab. Also zum Beispiel in wb1 "John" ist der Name in A1, wechseln Sie zu wb2, gehen Sie zu dem Blatt namens John, überprüfen Sie die Kriterien auf Zelle A4 dieses Blattes: Es gibt 3 Kriterien: Teen, Erwachsene oder Elder

Wenn Teenager, dann B1 in B97 zu kopieren, C1 in B135 kopieren, kopieren Sie D1 in B147 & B190, kopieren E4 in B1100

Wenn Erwachsener, dann J1 kopieren in B97, kopieren F1 in B135, kopieren G1 in B147 & B190, Kopie H4 in B1100

Wenn Elder, kopieren Sie dann B1 in B97, co py C1 in B135, kopieren D1 in B147 & B190, kopieren E4 in B1100, kopieren J1 in B113, kopieren F1 in B1910, Kopier G1 in B1473 & B1930, kopieren H4 in B1190

(Das obige ist nur ein Beispiel, Es gibt mehr Zellen zum Kopieren der Paste als oben aufgeführt)

Dies sollte für alle Namen in Spalte A von wb1 geloopt werden.

Unten ist, was Makro-Datensatz gab mir, aber es notiert die Kriterien nicht. Beide Arbeitsmappen werden übrigens geöffnet sein.

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 

    Set wb1= ThisWorkbook 
    Set Sht = MasterBook.Worksheets("Sheet") 
    Set Rng = Sht.Range("A2:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 
    Dim wb2 As Workbook 
    Dim cell As Range 
    For Each cell In Rng '<---Here is where my first problem is, 
'not sure how to get the excel to switch to the sheet 
'with the same name as in column A then check cell A4 for the criteria' 

    If cell.Value = "Teen" Then 
    Range("C12").Select 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=81 
     Range("B97").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-9 
     Windows("wb1.xlsx").Activate 
     Range("D12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=12 
     Range("B95").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("E12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-45 
     Range("B47").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=63 
     Range("B118").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("F12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=48 
     Range("B163").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("G12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-66 
     Range("B93").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("H12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=9 
     Range("B105").Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     ActiveWindow.SmallScroll Down:=60 
     Range("B167").Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
     Windows("wb1.xlsx").Activate 
     Range("I12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=-27 
     Range("B141").Select 
     ActiveSheet.Paste 
     Windows("wb1.xlsx").Activate 
     Range("J12").Select 
     Application.CutCopyMode = False 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     Range("B145").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=138 
     Windows("wb1.xlsx").Activate 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=51 
     Range("B326").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=12 
     Range("B339").Select 
     Application.CutCopyMode = False 
     ActiveCell.FormulaR1C1 = "1" 
     Range("B317").Select 
     ActiveCell.FormulaR1C1 = "1" 
     Range("B312").Select 
     ActiveCell.FormulaR1C1 = "1" 
     Windows("wb1.xlsx").Activate 
     Range("K12").Select 
     Selection.Copy 
     Windows("wb2.xlsx").Activate 
     Range("B107").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-63 
     Range("B49").Select 
     ActiveSheet.Paste 
     ActiveWindow.SmallScroll Down:=-9 
     Windows("wb1.xlsx").Activate 
     Windows("wb2.xlsx").Activate 
     ActiveWindow.SmallScroll Down:=306 
     Windows("wb1.xlsx").Activate 

    else If cell.Value = "Adult" Then 
    '<-----same stuff as above for different cells copy pasted' 
    else If cell.Value = "Elder" Then 
    '<-----same stuff as above for different cells copy pasted' 
end if 
    End Sub 

Auch ich weiß nicht, ob die Case-Funktion anstelle der If-Anweisung auch hier nützlich wäre.

Vielen Dank im Voraus

EDIT 1

ich den Code geändert, wie unten

vorgeschlagen

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 
    Dim wb2 As Workbook 
    Dim cell As Range 

    Set wb1 = ThisWorkbook 
    Set wb2 = Workbooks("Measure Templates.xlsx") 
    Set Sht = wb1.Worksheets("Summary") 
    Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 

    For Each cell In Rng 
     Select Case wb2.Sheets(cell.Text).Range("A4").Value 
      Case "Standard Bathroom Template" 
      wb1.Sheet("Summary").Range("B5").Value = wb2.ActiveSheet.Range("B97") '<--- I'm getting an error here saying "Object doesn't support this property or method" 
'I assume that this is not the right way to copy paste. 
'I looked around but everything online uses a specific sheet name for destination 
'which is not the case for me, it should be sheet with same name as in column A 
       wb1.Sheet("Summary").Range("C5").Value = wb2.ActiveSheet.Range("B117") 
       Case "Standard Kitchen Template" 
       wb1.Sheet("Summary").Range("B6").Value = wb2.ActiveSheet.Range("B97") 
       wb1.Sheet("Summary").Range("C6").Value = wb2.ActiveSheet.Range("B117") 
       Case "Standard Bathroom and Kitchen T" 
       wb1.Sheet("Summary").Range("B7").Value = wb2.ActiveSheet.Range("B97") 
       wb1.Sheet("Summary").Range("C7").Value = wb2.ActiveSheet.Range("B117") 
      End Select 
     Next cell 

    End Sub 

Answer 1

Haben aktualisiert und eine Blattgröße (ws), die an den entsprechenden Stellen Blatt zum Kopieren (es muss nicht ausgewählt oder aktiv sein).

Sub Summary() 

    Dim wb1 As Workbook 
    Dim Sht As Worksheet 
    Dim Rng, Rng2 As Range 
    Dim wb2 As Workbook 
    Dim cell As Range 
    Dim ws as Worksheet 

    Set wb1 = ThisWorkbook 
    Set wb2 = Workbooks("Measure Templates.xlsx") 
    Set Sht = wb1.Worksheets("Summary") 
    Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row) 

    For Each cell In Rng 
     Set ws=wb2.Sheets(cell.Text) 
     Select Case ws.Range("A4").Value 
      Case "Standard Bathroom Template" 
      wb1.Sheet("Summary").Range("B5").Value = ws.Range("B97").Value 
      wb1.Sheet("Summary").Range("C5").Value = ws.Range("B117").Value 
       Case "Standard Kitchen Template" 
       wb1.Sheet("Summary").Range("B6").Value = ws.Range("B97").Value 
       wb1.Sheet("Summary").Range("C6").Value = ws.Range("B117").Value 
       Case "Standard Bathroom and Kitchen T" 
       wb1.Sheet("Summary").Range("B7").Value = ws.Range("B97").value 
       wb1.Sheet("Summary").Range("C7").Value = ws.Range("B117").Value 
      End Select 
     Next cell 

    End Sub