Macro to convert 1 row into multiple rows except for zeroes

[Vbanoob98]

Hi guys here is the 2 macros I have for this issue. The first one transforms one row from into 4 different rows and the next one removes the rows that have a zero. This way seems to crude and I was wondering how would I improve it. I'm thinking arrays and ranges probably? Thanks a lot


Sub ImportIntoAccess()

Sheets("RC").Select
Range("b2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("A1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste


Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("b1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("c1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste


Sheets("RC").Select
Range("h2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("d1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Range("e2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Loans​"
LastRow = Range("D" & Rows.Count).End(xlUp).Row
ActiveCell.AutoFill Range(ActiveCell.Address, Cells(LastRow, ActiveCell.Column))

Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "3"
LastRow = Range("D" & Rows.Count).End(xlUp).Row
ActiveCell.AutoFill Range(ActiveCell.Address, Cells(LastRow, ActiveCell.Column))

Sheets("RC").Select
Range("b2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("b1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("c1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("f2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("d1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste


Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "4"
LastRow = Range("D" & Rows.Count).End(xlUp).Row
ActiveCell.AutoFill Range(ActiveCell.Address, Cells(LastRow, ActiveCell.Column))

Sheets("RC").Select
Range("b2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("b1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("c1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste

Sheets("RC").Select
Range("g2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("AccessImport").Select
Range("d1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste


Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "5"
LastRow = Range("D" & Rows.Count).End(xlUp).Row
ActiveCell.AutoFill Range(ActiveCell.Address, Cells(LastRow, ActiveCell.Column))
End Sub

Sub Delete_Chg_Total_zero()

Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "D").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, 4) = 0 Then
Rows(r).Delete
End If
Next r
End Sub​

Here is the link to my spreadsheet

https://drive.google.com/file/d/11xG_cbu-HglAqX6a8XwjuolzHOmC3za7/view?usp=drivesdk

Or if this is not allowed please advise how to post it. Thanks!

 

[My Aswer Is This]

I never click on links to Excel files:

This is way to much code for me to read and understand what your attempting to do.

Would you please tell me in words what exactly your attempting to do.

Please be specific with your details.

Please do not say: Read my code.

 

[Vbanoob98]

Thanks. I'll simplify.

I have a worksheetsheet with 150 rows that have to be converted into 3 rows each based on if column B,C,D have a number or not. This has to go into another worksheet

Worksheet 1
Entity Q1 Q2 Q3
CompanyA 40 50 0
CompanyB 30 0 60
This has to turn into:
Worksheet 2
Entity Amount Quarter
CompanyA 40 1
CompanyA 50 2
CompanyB 30 1
CompanyB 60 3
... ... ...




Thanks for your time ​

Sorry for format, can't figure it on phone. :/

 

[My Aswer Is This]

So are you saying you want to search columns A B and C of sheet1

And all the cells in column A that have a number should be entered into Row1 of sheet2

And all the cells in column B that have a number should be entered into Row2 of sheet2

And all the cells in column C that have a number should be entered into Row3 of sheet2


And if so what might we find in these 3 columns?

Will the cells without numbers be empty?

Or might the cells in column A have something like: 5644 Maryland Blvd.

And this would be considered as a number?
​

_{^{<strike>
</strike>}}​

 

[Vbanoob98]

[table="width: 500, class: grid"]
[tr]
[td]Entity[/td]
[td]Q1[/td]
[td]Q2[/td]
[td]Q3[/td]
[/tr]
[tr]
[td]CompanyA[/td]
[td]40[/td]
[td]50.[/td]
[td]0[/td]
[/tr]
[tr]
[td]CompanyB[/td]
[td]30[/td]
[td]0[/td]
[td]60[/td]
[/tr]
[/table]

So it should go like this

[table="width: 500, class: grid"]
[tr]
[td]entity[/td]
[td]amount[/td]
[td]quarter[/td]
[/tr]
[tr]
[td]companyA[/td]
[td]40[/td]
[td]Q1[/td]
[/tr]
[tr]
[td]companyA[/td]
[td]50[/td]
[td]Q2[/td]
[/tr]
[tr]
[td]CompanyB[/td]
[td]30[/td]
[td]Q1[/td]
[/tr]
[tr]
[td]CompanyB[/td]
[td]60[/td]
[td]Q3[/td]
[/tr]
[/table]

I just want to copy sheet1 and transform it into sheet 2. Without copying the cells with 0. Everything is numbers except the names lf the entities

 

[Peter_SSs]

Based on what you have shown in post 5, try this in a copy of your workbook. Check the sheet names in the code match yours.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  With Sheets("Sheet1")
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 4).Value
  End With
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 1), 1 To 3)
  For i = 2 To UBound(a)
    For j = 2 To uba2
      If a(i, j) <> 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, j)
        b(k, 3) = a(1, j)
      End If
    Next j
  Next i
  With Sheets("Sheet2")
    .Range("A1:C1").Value = Array("Entity", "Amount", "Quarter")
    .Range("A2").Resize(k, 3).Value = b
  End With
End Sub

 

[Vbanoob98]

That works beautifully. Thanks!

I'm having trouble increasing the size of the array, any pointers? I want it to cover from column A to column. So as to copy more columns into the new sheet.



Lets say

 

[Peter_SSs]

That works beautifully. Thanks!

Good start then.

I'm having trouble increasing the size of the array, any pointers? I want it to cover from column A to column. So as to copy more columns into the new sheet.

Would need to know ..
- What columns have data altogether (eg columns A:J)
- Which columns contain the quarterly data that has to checked for 0 or not and made into new rows. In the sample I used that was columns B:D

 

[Vbanoob98]

-Columns A:H

-Columns F:H

I managed to make it work but I literally tweaked everything until it worked. Still have trouble understanding why. Loops are no easy thing

b(k,1) = a(i,2)
b(k,2) = a(i,1)
b(k,3) = a(i,1)
b(k,4) = a(i,j)
b(k,7) = a(1,j)

 

[Peter_SSs]

-Columns A:H

-Columns F:H

This would be my version.

Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long, z As Long
  
  With Sheets("Sheet1")
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 8).Value
  End With
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 1), 1 To 7)
  For i = 2 To UBound(a)
    For j = 6 To uba2
      If a(i, j) <> 0 Then
        k = k + 1
        For z = 1 To 5
          b(k, z) = a(i, z)
        Next z
        b(k, 6) = a(i, j)
        b(k, 7) = a(1, j)
      End If
    Next j
  Next i
  With Sheets("Sheet2")
    .Range("A1:E1").Value = Application.Index(a, 1, Array(1, 2, 3, 4, 5))
    .Range("F1:G1").Value = Array("Amount", "Quarter")
    .Range("A2").Resize(k, 7).Value = b
  End With
End Sub