Kopieren von Daten aus einem Arbeitsblatt und Einfügen in relevanten Zeilen in einem anderen Arbeitsblatt

Question

Ich habe eine Arbeitsmappe mit zwei Blättern eine namens Datadump mit Kopfzeilen in Zeile 1 und Standort und beschreibende Daten in Spalten A & B und Daten in Spalte C. Ich möchte Kopieren Sie diese Daten und fügen Sie sie in das Arbeitsblatt "Factors" ein.

Dieses Arbeitsblatt hat Spaltenüberschriften auf der Reihe 2 und den gleichen beschreibenden Titel in Spalten A & B. Ich mag die Daten von „DataDump“ einzufügen gegen dieselbe Reihe Etikett in „Factors“ in Spalte E .

„Factors“ wird jedoch haben einige Zeilen, die so muss es einzufügen gegen entsprechenden Zeilen nicht in „DataDump“ sind. Ich habe verschiedene Code ausprobiert, der nicht funktioniert. Unten ist das Neueste, aber es erscheint ein Runtime 1004-Fehler in der Pastenspecial-Zeile. Wenn jemand helfen könnte, wäre das großartig.

Dank

'VARIABLE NAME     'DEFINITION 
Dim SourceSheet As Worksheet 'The data to be copied is here 
Dim TargetSheet As Worksheet 'The data will be copied here 
Dim ColHeaders As Range   'Column headers on Target sheet 
Dim MyDataHeaders As Range  'Column headers on Source sheet 

Dim DataBlock As Range   'A single column of data 
Dim c As Range     'a single cell 
Dim Rng As Range    'The data will be copied here (="Place holder" for the first data cell) 
Dim i As Integer 

Set SourceSheet = Sheets("Datadump") 
Set TargetSheet = Sheets("Factors") 

With TargetSheet 
    Set ColHeaders = .Range("A2:E2") 
    Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 
End With 

With SourceSheet 
    Set MyDataHeaders = .Range("A1:C1") 

    For Each c In MyDataHeaders 
     If Application.WorksheetFunction.CountIf(ColHeaders, c.value) = 0 Then 
      MsgBox "Can't find a matching header name for " & c.value & vbNewLine & "Make sure the column names are the same and try again." 
      Exit Sub 
     End If 
    Next c 

    Set DataBlock = .Range(.Cells(2, 3), .Cells(.Rows.Count, 1).End(xlUp)) 
    Set Rng = Rng.Resize(DataBlock.Rows.Count, 1) 

    For Each c In MyDataHeaders 
     i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0) 
     Set c = DataBlock 
     If Not c Is Nothing Then 
      .Columns(c.Column).Copy 
      c.PasteSpecial xlPasteValues 
     End If 
    Next 
    Application.CutCopyMode = False 
End With 

End Sub 

Answer 1

Der Code unten wird die Arbeit tun,

For i = 2 To 100 'considering 100 rows in Datadump sheet 
    site1 = Sheets("Datadump").Cells(i, 1).Value 
    desc1 = Sheets("Datadump").Cells(i, 2).Value 
    For j = 3 To 50 'considering 50 rows in Factors sheet 
     site2 = Sheets("Factors").Cells(j, 1).Value 
     desc2 = Sheets("Factors").Cells(j, 2).Value 
     If site1 = site2 And desc1 = desc2 Then 
      Sheets("Factors").Cells(j, 5).Value = Sheets("Datadump").Cells(i, 3).Value 
     End If 
    Next j 
Next i