Kopieren und Einfügen Datenabgleich

Question

Ich habe FileA mit Rohdaten. Die blauen Zellen sind Header, die mit A-J bezeichnet sind. Die pfirsichfarbenen Zellen stellen die Daten dar, bei denen es sich typischerweise um Text handelt, der variiert und nicht konstant ist und mit 1 bis 10 gekennzeichnet ist.

Datei A:

Datei B:

Das zweite Blatt enthält die Header in blau, wie oben beschrieben.

Ich konnte einen VBA-Code nicht schreiben, um den angegebenen Header zu einer Spalte zu passen und die folgenden Daten in der nächsten verfügbaren Zelle einzufügen. I.e. (A1, A5, A8, A11, A14, A17 sind auf ihre jeweiligen Header abgestimmt und eingefügt in das zweite Blatt in A2, A3, A4, A5, A6, A7)

Sie werden feststellen, dass in den Rohdaten es ist nicht vollständig konstant, Zeilen 4-5, 10-12, 13-14 fehlen Daten für Spalte F, was es schwieriger macht, in einem großen Datensatz übereinzustimmen.

der aktuelle Code, der nahe kommen, zu helfen, aber nicht funktioniert wird unten geschrieben:

Dim wbk As Workbook 
Set wbk = ThisWorkbook 
Set ws = wbk.Sheets(1) 
Set ws2 = wbk.Sheets(2) 
Dim cell As Range 
Dim refcell As Range 

Application.ScreenUpdating = False 
ws.Select 

    For Each cell In ws.Range("A1:Z1") 

     cell.Activate 
     ActiveCell.Offset(1, 0).Copy 

     For Each refcell In ws2.Range("A1:Z1") 
      If refcell.Value = cell.Value Then refcell.Paste 
     Next refcell 

    Next cell 
    Application.ScreenUpdating = False 

Zusatz:

Dim wbk As Workbook 
Set wbk = ThisWorkbook 
Set ws = wbk.Sheets(1) 
Set WS2 = wbk.Sheets(2) 
Dim cell As Range 
Dim refcell As Range 
Dim Col As Long 

Application.ScreenUpdating = False 
ws.Select 

    For Each cell In ws.Range("A1:Z15000") 

     cell.Activate 
     Col = Application.WorksheetFunction.Match(WS2.Range("Cell").Value.Rows("1:1"), False) 

     For Each refcell In WS2.Range("A1:Z1") 
      Cells(Rows.Count, Col).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 
     Next refcell 

    Next cell 
Application.ScreenUpdating = True 

Answer 1

Sie den anderen Weg gehen können um:

Option Explicit 

Sub main() 
    Dim hedaerCell As Range 
    Dim labelsArray As Variant 

    With ThisWorkbook.Worksheets("Sheet02") '<--| reference your "headers" worksheet 
     For Each hedaerCell In .Range("A1:J1") '<--| loop through all "headers" 
      labelsArray = GetValues(hedaerCell.value) '<--| fill array with all labels found under current "header" 
      .Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).value = Application.Transpose(labelsArray) '<--| write down array values from current header cell column first not empty cell 
     Next 
    End With 
End Sub 

Function GetValues(header As String) As Variant 
    Dim f As Range 
    Dim firstAddress As String 
    Dim iFound As Long 

    With ThisWorkbook.Worksheets("Sheet01").UsedRange '<--| reference your "data" worksheet 
     ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences 
     Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header' 
     If Not f Is Nothing Then 
      firstAddress = f.Address 
      Do 
       iFound = iFound + 1 
       labelsArray(iFound) = f.Offset(1) 
       Set f = .FindNext(f) 
      Loop While f.Address <> firstAddress 
     End If 
    End With 
    GetValues = labelsArray 
End Function