Inserting new rows base on cell value, copying cell value on the first 3 column and transpose data for the rest

[llbac]

Hi everyone,
I have a similar question with other posts but different a little bit.
I have no experience in VBA and English is not my native language, so please accept my apologize and tell me if my question is unclear.
I would like to write the VBA code that can convert Table 1 to Table 2, which are:
1/ Table 1 locate on the Sheet1, start from A1 cell.
The first rows is column's titles
There are at least 4 columns. The first 3 columns are always text. From the 4th column onwards are always numeric (integer) value.
Data on the first 4 columns are always filled. On the next column onwards, maybe have one or more numeric values.

Fomular-test.xlsx
	A	B	C	D	E	F	G	H	I
1	Title A	Title B	Title C	Title D	Title E	Title F	Title G	Title H	Title I
2	Context A1	Context B1	Context C1	Number D1	Number E1	Number F1
3	Context A2	Context B2	Context C2	Number D2	Number E2	Number F2	Number G2	Number H2	Number I2
4	Context A3	Context B3	Context C3	Number D3
5	Context A4	Context B4	Context C4	Number D4	Number E4	Number F4
6	Context A5	Context B5	Context C5	Number D5	Number E5
Sheet1

2/ Table 2 locate on the new sheet (for example, named Sum).
In short, table 2 will transpose data on the 5th column onwards (if available) to the 4th column, while the first 3 columns' cell values will be copied from their corresponding cells above.

In my real data, value of column E (the 5th) will appear randomly, however, always in order (i.e: D-E, D-E-F, or D-E-F-G-H-H-J etc.).

Fomular-test.xlsx
	A	B	C	D	E	F	G	H	I
1	Title A	Title B	Title C	Title D	Title E	Title F	Title G	Title H	Title I
2	Context A1	Context B1	Context C1	Number D1
3	Context A1	Context B1	Context C1	Number E1
4	Context A1	Context B1	Context C1	Number F1
5	Context A2	Context B2	Context C2	Number D2
6	Context A2	Context B2	Context C2	Number E2
7	Context A2	Context B2	Context C2	Number F2
8	Context A2	Context B2	Context C2	Number G2
9	Context A2	Context B2	Context C2	Number H2
10	Context A2	Context B2	Context C2	Number I2
11	Context A3	Context B3	Context C3	Number D3
12	Context A4	Context B4	Context C4	Number D4
13	Context A4	Context B4	Context C4	Number E4
14	Context A4	Context B4	Context C4	Number F4
15	Context A5	Context B5	Context C5	Number D5
16	Context A5	Context B5	Context C5	Number E5
Sum2

Thank you very much!

 

[Legacy 143009]

Not the most efficient bu does the job:

Sub test()
  Dim myRange As Range, i As Long
  Set myRange = UsedRange
  For r = myRange.Rows.Count To 2 Step -1
  i = 0
    For c = myRange.Columns.Count To 5 Step -1
      If myRange.Cells(r, c).Value2 <> "" Then
        myRange.Rows(r + 1).EntireRow.Insert
        myRange.Cells(r + 1, 4) = myRange.Cells(r, c)
        i = i + 1
      End If
    Next
    If i > 0 Then
      myRange.Cells(r, 5).Resize(1, myRange.Columns.Count - 4) = ""
      myRange.Cells(r + 1, 1).Resize(i, 3).Value2 = myRange.Cells(r, 1).Resize(1, 3).Value2
    End If
  Next
End Sub

 

[llbac]

Thanks for your prompt response.
Unfortunately, I got Error 424:

What should I do?

 

[Legacy 143009]

Could you please try to specify the sheet name?
Set myRange = Worksheets("Sum2").UsedRange

 

[llbac]

Could you please try to specify the sheet name?
Set myRange = Worksheets("Sum2").UsedRange

I have just changed the code to this:

Sub Convert_table()
  Dim myRange As Range, i As Long
  Set myRange = Worksheets("Sum").UsedRange
  For r = myRange.Rows.Count To 2 Step -1
  i = 0
    For c = myRange.Columns.Count To 5 Step -1
      If myRange.Cells(r, c).Value2 <> "" Then
        myRange.Rows(r + 1).EntireRow.Insert
        myRange.Cells(r + 1, 4) = myRange.Cells(r, c)
        i = i + 1
      End If
    Next
    If i > 0 Then
      myRange.Cells(r, 5).Resize(1, myRange.Columns.Count - 4) = ""
      myRange.Cells(r + 1, 1).Resize(i, 3).Value2 = myRange.Cells(r, 1).Resize(1, 3).Value2
    End If
  Next
End Sub

I have already create a sheet named 'Sum'. However, there is nothing happened. No table is created on sheet Sum.

 

[llbac]

Could you please try to specify the sheet name?
Set myRange = Worksheets("Sum2").UsedRange

Also, I am currently working with Sheet1 which the original table is on. The expected result should be on sheet "Sum". Should the code indicates something about that?
Again, I have no experience in VBA coding so please don't be so surprised about my silly questions ^^!

 

[llbac]

Oh, I figure out that it I change from "Sum" to "Sheet1", then it works!
The problem is that it changes directly data on Sheet1 which I would like to retain.
I expect to create a new sheet, named "Sum", to paste the result onto it. However, I guess the way to work around is to duplicate the sheet and then run the marco.

Another question is that, could you please change the code so that it will work on the current sheet? In this way, it is not necessary to change the code every time I run because the sheet name will vary (a lot, about more than 30 sheets), which will help me to reduce the workload drastically.

 

[Legacy 143009]

I am so confused Please specify which is the source sheet and which will be the destination sheet?

 

[Legacy 143009]

Ok this should work:

Sub Test()
  Dim myRange As Range, i As Long
  Set myRange = Worksheets("Sheet1").UsedRange
  i = 2
  With myRange
    Worksheets("Sum").Cells(1, 1).Resize(, .Columns.Count).Value2 = .Cells(1, 1).Resize(, .Columns.Count).Value2
    For r = 2 To .Rows.Count
      For c = 4 To .Columns.Count
        If Not IsEmpty(myRange(r, c)) Then
          Worksheets("Sum").Cells(i, 1).Resize(, 3).Value2 = .Cells(r, 1).Resize(, 3).Value2
          Worksheets("Sum").Cells(i, 4).Value2 = .Cells(r, c).Value2
          i = i + 1
        End If
      Next
    Next
  End With
End Sub

 

[llbac]

Ok this should work:

Sub Test()
  Dim myRange As Range, i As Long
  Set myRange = Worksheets("Sheet1").UsedRange
  i = 2
  With myRange
    Worksheets("Sum").Cells(1, 1).Resize(, .Columns.Count).Value2 = .Cells(1, 1).Resize(, .Columns.Count).Value2
    For r = 2 To .Rows.Count
      For c = 4 To .Columns.Count
        If Not IsEmpty(myRange(r, c)) Then
          Worksheets("Sum").Cells(i, 1).Resize(, 3).Value2 = .Cells(r, 1).Resize(, 3).Value2
          Worksheets("Sum").Cells(i, 4).Value2 = .Cells(r, c).Value2
          i = i + 1
        End If
      Next
    Next
  End With
End Sub

This code worked flawlessly! Thank you very much!
By the way, could you please help me to change to code a little bit more?
I would like to convert the table at the current worksheet without needing to know the current sheet's name (in this case, Sheet1).
For example, if I am working on the sheet XYZ, and this VBA should still work, then I will move to another sheet to repeat this code.

I tried:

Sub Test()
  Dim myRange As Worksheet, i As Long
  Set myRange = ActiveSheet
  i = 2
  With myRange
    Worksheets("Sum").Cells(1, 1).Resize(, .Columns.Count).Value2 = .Cells(1, 1).Resize(, .Columns.Count).Value2
    For r = 2 To .Rows.Count
      For c = 4 To .Columns.Count
        If Not IsEmpty(myRange(r, c)) Then
          Worksheets("Sum").Cells(i, 1).Resize(, 3).Value2 = .Cells(r, 1).Resize(, 3).Value2
          Worksheets("Sum").Cells(i, 4).Value2 = .Cells(r, c).Value2
          i = i + 1
        End If
      Next
    Next
  End With
End Sub

But the Error '438' pop out: Object doesn't support this property or method at line:

 If Not IsEmpty(myRange(r, c)) Then