Macro to convert 1 row into multiple rows except for zeroes

Vbanoob98

Board Regular
Joined
Sep 13, 2019
Messages
96
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!
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
16,728
Office Version
2013
Platform
Windows
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

Board Regular
Joined
Sep 13, 2019
Messages
96
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. :/
 
Last edited:

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
16,728
Office Version
2013
Platform
Windows
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

Board Regular
Joined
Sep 13, 2019
Messages
96
EntityQ1Q2Q3
CompanyA4050.0
CompanyB30060

So it should go like this

entityamountquarter
companyA40Q1
companyA50Q2
CompanyB30Q1
CompanyB60Q3

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
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
43,660
Office Version
365
Platform
Windows
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.

Rich (BB code):
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

Board Regular
Joined
Sep 13, 2019
Messages
96
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
43,660
Office Version
365
Platform
Windows
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

Board Regular
Joined
Sep 13, 2019
Messages
96
-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

Code:
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)
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
43,660
Office Version
365
Platform
Windows
-Columns A:H

-Columns F:H
This would be my version.

Rich (BB code):
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
 

Watch MrExcel Video

Forum statistics

Threads
1,090,116
Messages
5,412,530
Members
403,432
Latest member
cr2141

This Week's Hot Topics

Top