1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

  3. 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

Discussion in 'VBA Macros' started by paneliyadhruv, Jul 4, 2018.

  1. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    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 (vb):
    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
  2. Chihiro

    Chihiro Excel Ninja

    Messages:
    4,935
    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.
  3. Stevie

    Stevie Active Member

    Messages:
    112
    Chihiro's idea would look something like:
    Code (vb):
    Sub runall()

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

    End Sub
    paneliyadhruv and Chihiro like this.
  4. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    Reason for combine into one as input range and output range having similar sequence.
  5. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    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.
  6. Chihiro

    Chihiro Excel Ninja

    Messages:
    4,935
    I'd recommend you upload sample workbook then. Without it, bit hard to validate combined code against current result.
  7. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    sample file with macro uploaded

    Attached Files:

  8. Stevie

    Stevie Active Member

    Messages:
    112
    Try this:
    Code (vb):
    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
    paneliyadhruv likes this.
  9. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    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.
  10. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    Dear Sir,
    Working perfectly after changing code as below.
    Code (vb):
    For orow = 0 To irange.Offset(irow, icol).Value
    to
    Code (vb):
    For orow = 1 To irange.Offset(irow, icol).Value
    Thank you very much for your time and help.
    Stevie likes this.
  11. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    Code (vb):
    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.
  12. Marc L

    Marc L Excel Ninja

    Messages:
    4,253

    Hi !

    Attach a workbook with the expected result filled …​
  13. Stevie

    Stevie Active Member

    Messages:
    112
    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.
  14. Marc L

    Marc L Excel Ninja

    Messages:
    4,253

    I agree …​
  15. paneliyadhruv

    paneliyadhruv Member

    Messages:
    50
    Thank you sir. I will create new post.

Share This Page