Sorting out data by insert and copy and paste special

Question

I am currently trying to sort out data. This is the given data. The list goes on and the numbers of 123 will vary.

Header  Header                      
A         1    2    3   4   5       
B         1    2    3   4   5   6   7
C         1    2        
....
....
....        

What it should look after being sort out

Header  Header 
 A      1
 A      2
 A      3
 A      4
 A      5
 B      1
 B      2
 B      3
 B      4
 B      5 
 B      6
 B      7
 C      1
 C      2

I have tried doing the codes for this by using insert, copy and paste special. I am trying to work with a small number first to test out but it doesn't seem to work with the loop. Does anyone have any suggestions on how I can do this or what can improve on?

s = 3
x = 0
w = 2
For d = 0 To 1 Step 1
    y = 3
    x = 0
    Do Until IsEmpty(Sheet1.Cells(w, y).Value)
        y = y + 1
        x = x + 1
    Loop
    Rows(s & ":" & v + 2).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    z = x + 2
    Set ran = Sheet1.Range(Sheet1.Cells(w, s), Sheet1.Cells(w, z))
    ran.Copy
    Sheet1.Range(Sheet1.Cells(s, w), Sheet1.Cells(s, w)).PasteSpecial 
    Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
   False, Transpose:=True
    Application.CutCopyMode = False
    ran.Clear
    w = w + v + 1
    s = s + v
Next d

Answer 1

It took so many time but here we go,

Sub mertinc()
    Dim mert, inc As Long
    Application.ScreenUpdating = False
    Range("a1048576").Select
    mert = Selection.End(xlUp).Row

    Dim mertindex As Integer
    mertindex = 1

    Do While mertindex <= mert
        Range("a" & mertindex).Activate
        inc = Range(Selection.Offset(0, 1), Selection.End(xlToRight)).Count

        Range(Selection.Offset(0, 1), Selection.End(xlToRight)).Copy

        Range("XX1048576").Select
        Selection.End(xlUp).Offset(1, 0).Select


        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True

        Range("XW1048576").Select
        Selection.End(xlUp).Offset(1, 0).Resize(inc, 1).Select


        Selection.Value = Range("a" & mertindex).Value

        mertindex = mertindex + 1
    Loop
    Application.ScreenUpdating = True 
End Sub

In this example, you can get exactly what you want in the XW and XX columns. You can create another page to create this list over there, or you can clear your previous list and copy new one instead of them. That's up to you now.

If you don't understand any part of the code, let me know.

Answer 2

This is just to see how we can improve Mertinc's code to follow best practices with some minor improvements.

This is expressly not to blame anyone but good for learning purpose and seeing the differences.

Option Explicit

Sub TransformData()
    Dim lastRowScr As Long, lastRowDest As Long
    Dim numCols As Long
    
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")   '* worksheet with source data
    Set wsDest = ThisWorkbook.Worksheets("Sheet2")  '* another worksheet to paste data
    
    Application.ScreenUpdating = False
    lastRowScr = wsSrc.Range("A" & wsSrc.Rows.Count).End(xlUp).Row '* determine last row in column A

    Dim iRow As Long
    iRow = 1

    Do While iRow <= lastRowScr
        With wsSrc.Range(wsSrc.Range("B" & iRow), wsSrc.Range("A" & iRow).End(xlToRight))
            numCols = .Count
            .Copy
        End With
        
        With wsDest
            lastRowDest = .Range("B" & .Rows.Count).End(xlUp).Row
            If IsEmpty(.Range("B" & lastRowDest)) Then lastRowDest = lastRowDest - 1 '* make sure that we start in row 1
            
            .Range("B" & lastRowDest + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Range("A" & lastRowDest + 1).Resize(numCols, 1).Value = wsSrc.Range("A" & iRow).Value
        End With
        iRow = iRow + 1
    Loop
    Application.ScreenUpdating = True
End Sub

This procedure uses sheet1 as data source and inserts the transformed data into sheet2.

---

Explanations

Here I try to explain the differences and show some further literature.

1. Always use descriptive variable and procedure/function naming

Using your username for naming procedures and variables

Sub mertinc()
    Dim mert, inc As Long

is bad practice instead you should use descriptive names like

Sub TransformData()
    Dim lastRowScr As Long, lastRowDest As Long
    Dim numCols As Long

also every variable needs to be specified with a type. Dim mert, inc As Long will leave mert as variant and only declares inc as long.

Much better readability for yourself and other persons and therefore probably less issues in your codes.

---

2. Always use long instead of integer

Never use integer unless you need to interop with an old API call that expects a 16 bit int. There is no advantage using integer instead of long.

---

3. Avoid using Select or Activate

Instead of using .Select or .Activate

Range("a1048576").Select
lastRowScr = Selection.End(xlUp).Row

use a direct access

lastRowScr = Range("a1048576").End(xlUp).Row

Much faster and shorter code.

---

4. Also never assume the worksheet

Always use full qualified ranges

Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRowScr = ws.Range("a1048576").End(xlUp).Row

Less issues. If another sheet was selected, this code still works.

---

5. Never use fixed row counts

Instead of fixed row counts

lastRowScr = ws.Range("a1048576").End(xlUp).Row

always detect the last row

lastRowScr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

Different Excel versions have different max. row counts. Therefore this code runs version independent.