• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Combine multiple macros having similar procedure

Dear All,

I have repeat data macro. Based on my requirement i have created multiple macro for selecting various ranges and output.
I need expert help to combine all macros in to single macro. My data start from columns A to CV.
for eg. First macro range A1 to A10 having text and b1 to b10 having numerical value for number of times repeat and output in column EA1
For second marco range b1 to b10 having text and c1 to c10 having numerical value for number of times repeat and output in column EB1. and so on till CV column.

Macro added for your valuable inputs.


Thank for your time and help in advance.

Code:
Private Sub RepeatData1()

On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("A1:b" & Range("a" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("b1:b" & Range("b" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(131).ClearContents
Sheet40.Range("Ea1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(131).AutoFit
End With
End Sub
Private Sub RepeatData2()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("c1:d" & Range("c" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("d1:d" & Range("d" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(132).ClearContents
Sheet40.Range("EB1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(132).AutoFit
End With
End Sub
Private Sub RepeatData3()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("e1:f" & Range("e" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("f1:f" & Range("f" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(133).ClearContents
Sheet40.Range("EC1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(133).AutoFit
End With
End Sub
Private Sub RepeatData4()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("G1:H" & Range("G" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("H1:H" & Range("H" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(134).ClearContents
Sheet40.Range("ED1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(134).AutoFit
End With
End Sub
Private Sub RepeatData5()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("I1:J" & Range("I" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("J1:J" & Range("J" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(135).ClearContents
Sheet40.Range("EE1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(135).AutoFit
End With
End Sub
Private Sub RepeatData6()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("K1:L" & Range("K" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("L1:L" & Range("L" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(136).ClearContents
Sheet40.Range("EF1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(136).AutoFit
End With
End Sub
Private Sub RepeatData7()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("M1:N" & Range("M" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("N1:N" & Range("N" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(137).ClearContents
Sheet40.Range("EG1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(137).AutoFit
End With
End Sub
Private Sub RepeatData8()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("O1:P" & Range("O" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("P1:P" & Range("P" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(138).ClearContents
Sheet40.Range("EH1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(138).AutoFit
End With
End Sub
Private Sub RepeatData9()


On Error Resume Next
With Worksheets("Calc2")
    .Activate
Dim a As Variant, c As Variant
Dim i As Long, ii As Long, N As Long
a = Range("Q1:R" & Range("Q" & Rows.Count).End(xlUp).Row)
N = Application.Sum(Range("R1:R" & Range("R" & Rows.Count).End(xlUp).Row))


ReDim c(1 To N, 1 To 1)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 2) <> "" Or a(i, 2) <> 0 Then
    For N = 1 To a(i, 2)
      ii = ii + 1
      c(ii, 1) = a(i, 1)
    Next N
  End If
Next i
Sheet40.Columns(139).ClearContents
Sheet40.Range("EI1").Resize(UBound(c, 1), UBound(c, 2)) = c
Sheet40.Columns(139).AutoFit
End With
End Sub
 
Why combine it into single sub?
It's usually easier to maintain separate subs.

Just have another sub that's used to run each sub in succession.
 
Chihiro's idea would look something like:
Code:
Sub runall()

    Call RepeatData1
    Call RepeatData2
    Call RepeatData3
    Call RepeatData4
    Call RepeatData5
    Call RepeatData6
    Call RepeatData7
    Call RepeatData8
    Call RepeatData9

End Sub
 
For 1st range a1:b and output column 131
2nd range c1:d and output column 132
3rd range e1:f and output column 133 and so on till cu1:cv.
 
I'd recommend you upload sample workbook then. Without it, bit hard to validate combined code against current result.
 
Try this:
Code:
Sub allInOneMacro()
    Application.Calculation = xlManual
    Dim orange As Range
    Dim irange As Range
    Dim icol As Double
    Dim ocol As Double
    Dim irow As Double
    Dim orow As Double
    Dim counter As Double
    icol = 0
    ocol = 0
    irow = 0
    orow = 0
    Set orange = Sheets("Calc2").Range("EA1")
    Set irange = Sheets("Calc2").Range("A1")
    For icol = 1 To 99 Step 2
        counter = 0
        irow = 0
        While irange.Offset(irow, icol) <> ""
            For orow = 0 To irange.Offset(irow, icol).Value
                orange.Offset(counter, ocol) = irange.Offset(irow, icol - 1).Text
                counter = counter + 1
            Next
            irow = irow + 1
        Wend
        ocol = ocol + 1
    Next
    Application.Calculation = xlAutomatic
End Sub
 
Dear Sir,
Working for all selected range. However, output showing one additional value.
For eg. range column A to B (10 times repeat), in output period are repeated 11 times, from to also 11 times and so on for all ranges.

Thank you very much for your help. Need minor code change.
 
Dear Sir,
Working perfectly after changing code as below.
Code:
For orow = 0 To irange.Offset(irow, icol).Value

to
Code:
For orow = 1 To irange.Offset(irow, icol).Value

Thank you very much for your time and help.
 
Code:
Private Sub SplitColumn1()
    Dim rng As Range
    Dim InputRng As Range
    Dim OutRng As Range
    Dim xRow As Integer
    Dim xCol As Integer
    Dim xArr As Variant
    Dim i As Integer
    Dim xvalue As Variant
    Dim iRow As Integer
    Dim iCol As Integer
   
    On Error Resume Next
   
    Set InputRng = Sheets("Sheet1").Range("EA1:EA2200")
    xRow = Sheets("Sheet1").Range("b1")
    Set OutRng = Sheets("Sheet1").Range("EC1")

    Set InputRng = InputRng.Columns(1)
    xCol = InputRng.Cells.Count / xRow
    ReDim xArr(1 To xRow, 1 To xCol + 1)
    For i = 0 To InputRng.Cells.Count - 1
        xvalue = InputRng.Cells(i + 1)
        iRow = i Mod xRow
        iCol = VBA.Int(i / xRow)
        xArr(iRow + 1, iCol + 1) = xvalue
    Next
    OutRng.Resize(UBound(xArr, 1), UBound(xArr, 2)).Value = xArr
   
End Sub


Dear Sir,

I got macro which can split column based on value.
Columns to be split (as in above trail workbook).
Range of columns to be split from EA to FX.
No of row to be copied from first column is in B1 for EA, d1 for EB and so on.
Out put for each split column start from column GA.

Means move input range one column each time (EA till FX).
Values for splitting column B1, d1, f1, h1 till CY1,
Output start from GA.

Thank you very much for your help.
 
paneliyadhruv, Marc may correct me here, but this seems like a different issue to the one which I helped you solve at the start of this thread.
I would suggest that you open a new thread for this request.
 
Back
Top