Kopieren Einfügen VBA-Schleife

Question

Ich habe ein Problem bei der Ausführung meines VBA-Makros, das ich geschrieben habe, um ein Dataset zu transponieren. Das Hauptziel besteht darin, diesen Datensatz Zeile für Zeile zu übernehmen und ihn so zu transponieren, dass die Spalten B: K neue Zeilen sind. Hier

ist eine Probe von dem, was ich zu tun versucht:

http://i.imgur.com/4ywn17m.png

ich folgende VBA geschrieben habe, aber alles was man tut, ist im Grunde eine „Schatten Reihe“ in einem neuen Blatt zu schaffen , was ich nicht will.

Sub LoopPaste() 

Dim i As Long 
Dim firstRow As Long 
Dim lastRow As Long 
Dim wb As Workbook 
Dim sheet1 As Worksheet 
Dim sheet2 As Worksheet 

Set wb = ThisWorkbook 
Set sheet1 = wb.Sheets("Sheet1") 
Set sheet2 = wb.Sheets("Sheet2") 

'Find the last row with data 
lastRow = sheet1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row 

'This is the beginning of the loop 
For i = firstRow To lastRow 

    'Copying Company 
    sheet2.Range("A" & i) = sheet1.Range("A" & i).Value 

    'Copying Employees 
    sheet2.Range("B" & i) = sheet1.Range("B" & i).Value 
    sheet2.Range("B" & 1 + i) = sheet1.Range("C" & i).Value 
    sheet2.Range("B" & 2 + i) = sheet1.Range("D" & i).Value 
    sheet2.Range("B" & 3 + i) = sheet1.Range("E" & i).Value 

Next i 

End Sub 

Wie bekomme ich die Schleife, um eine neue Zeile für jeden Mitarbeiter zu erstellen?

Answer 1

Ich war gelangweilt und dachte mir das für Sie aus. * Sollte * ziemlich schnell und schmerzlos sein, aber möglicherweise erfordert, die Bereiche vorher zu kennen.

Private Sub this() 

    Dim a() As Variant 

    a = Application.Transpose(Worksheets(1).Range("a1:p1").Value) 

    ThisWorkbook.Sheets("Sheet1").Range("a1:p1").Value = vbNullString 

    ThisWorkbook.Sheets("Sheet1").Range("a1:a55").Value2 = a 

End Sub 

Answer 2

Dies sollte Ihnen die Idee geben:

Sub test() 
    Dim src As Range, c As Range, target As Range 
    Dim curRow As Long 
    Set src = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Range("A1").CurrentRegion.Offset(1, 0)) 
    Set target = Sheet2.Range("a1") 
    curRow = src.Cells(1, 1).Row 
    For Each c In src.Cells 
     If c <> "" Then 
      target = c.Value 
      If c.Column = 1 Then 
       Set target = target.Offset(0, 1) 'next column 
      Else 
       Set target = target.Offset(1, 0) 'next row 
      End If 
     Else 
      'back to col 1 
      If target.Column <> 1 Then Set target = target.Offset(0, -target.Column + 1) 
     End If 
    Next c 

End Sub