VBA copy values to other sheet with loop

Question

I'd like to speed my work using vba but have no idea how to achieve it.

Let me explain problem:

I have an array: 12/24, 24/36, 36/48, 48/52
Data from excel looks like this

First sheet

vba has to create in another sheet something like this

Second sheet

Is it possible? :)

Thank you in advance for any tips

Best

Maciej

Your coding of the 12/24/36 etc in col D is inconsistent - presumably making that a consistent pattern is not a problem ? Eg all numbrs separated by either - or / not either — Tin Bum, Feb 26 '19 at 23:35
What have you tried so far? SO is not a free code writing service. — z32a7ul, Feb 26 '19 at 23:43
Similar: https://stackoverflow.com/questions/8560718/split-comma-separated-entries-to-new-rows and https://stackoverflow.com/questions/50092648/split-cells-and-insert-in-a-new-row — Tim Williams, Feb 27 '19 at 00:01
I didn't look for a free code but just a tip how to start 'cause I'm not familiar with loops and conditions yet. user1302114 and Tim Williams answers are far enough for me:-) Thank you — Maciej Mazurek, Feb 27 '19 at 08:25

score 0 · Accepted Answer · answered Feb 27 '19 at 01:49

Try coding the following;

Loop through every row in the source data
   for each of these rows - check you have firstname, lastname, occupation and array data
   If You have then
      breakup the array data into its parts and
      for each part of the array data
         write a row in the 2nd sheet
         .. you may need a variable to keep track of which row you are at

That's about all there is to it Make a start and come back when you have coding questions

score 0 · Answer 2 · answered Feb 27 '19 at 20:01

This builds an array of results from an array containing the source data. See code comments for explanation.

Sub Macro11()

    Dim i As Long, j As Long, hdrs As Variant, arr1 As Variant, arr2 As Variant
    Dim delim1 As String, delim2 As String, lwr As Long, upr As Long

    'If 'results' worksheet exists, delete it
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("results").Delete
    Application.DisplayAlerts = True
    On Error GoTo -1

    'Collect original data
    With Worksheets("sheet4")

        hdrs = .Range(.Cells(1, "A"), .Cells(1, .Columns.Count).End(xlToLeft)).Value2
        arr1 = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Value2

    End With

    'Preliminary variable values
    delim1 = " - "
    delim2 = "/"
    ReDim arr2(LBound(arr1, 2) To UBound(arr1, 2), 1 To 1)

    'Process single rows into multiple rows
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        'lowest value
        lwr = Split(Split(arr1(i, 4), delim1)(0), delim2)(0)
        'highest value
        upr = Split(Split(arr1(i, 4), delim1)(1), delim2)(1)
        'from lowest to highest value in 4th column
        For j = lwr To upr - 1 Step 12
            'transpose arr1 to arr2 with split 4th column values
            arr2(1, UBound(arr2, 2)) = arr1(i, 1)
            arr2(2, UBound(arr2, 2)) = arr1(i, 2)
            arr2(3, UBound(arr2, 2)) = arr1(i, 3)
            arr2(4, UBound(arr2, 2)) = Chr(39) & j & Chr(47) & Application.Min(j + 12, upr)
            'make room for next row
            ReDim Preserve arr2(LBound(arr2, 1) To UBound(arr2, 1), _
                                LBound(arr2, 2) To UBound(arr2, 2) + 1)
        Next j
    Next i

    'Remove last empty row
    ReDim Preserve arr2(LBound(arr2, 1) To UBound(arr2, 1), _
                        LBound(arr2, 2) To UBound(arr2, 2) - 1)

    'Put processed values into new worksheet
    With Worksheets.Add(after:=Worksheets("sheet4"))

        .Name = "results"
        .Cells(1, "A").Resize(UBound(hdrs, 1), UBound(hdrs, 2)) = hdrs
        .Cells(2, "A").Resize(UBound(arr2, 2), UBound(arr2, 1)) = Application.Transpose(arr2)

    End With

End Sub

score -1 · Answer 3 · answered Feb 27 '19 at 00:29

Although Z32A7UL is right, this is not a free code writing service, here you are, i was bored, not very fancy, but sure works:

Sheet1 = "Input" Sheet2 = "Output"

Sub Macro1()
    Dim LastRow As Long
    On Error Resume Next
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If LastRow = 0 Then LastRow = 1
    On Error GoTo 0

    ThisWorkbook.Sheets("Input").Select
    With ThisWorkbook.Sheets("Input"):
        .Range("E1").FormulaR1C1 = "Arreglo"
        .Range("F1").FormulaR1C1 = "Extracto 1"
        .Range("G1").FormulaR1C1 = "Extracto 2"
        .Range("H1").FormulaR1C1 = "Extracto 3"
        .Range("I1").FormulaR1C1 = "Total"
        .Range("E2").FormulaR1C1 = "=SUBSTITUTE((SUBSTITUTE(SUBSTITUTE(RC[-1],""-"",""""),""/"","""")),"" "","""")"
        .Range("F2").FormulaR1C1 = "=MID(RC[-1],1,2)&""/""&MID(RC[-1],3,2)"
        .Range("G2").FormulaR1C1 = "=MID(RC[-2],3,2)&""/""&MID(RC[-2],5,2)"
        .Range("H2").FormulaR1C1 = "=MID(RC[-3],5,2)&""/""&MID(RC[-3],7,2)"
        .Range("I2").FormulaR1C1 = "=COUNTA(RC[-3]:RC[-1])-COUNTBLANK(RC[-3]:RC[-1])"
        .Range("E2:I2").AutoFill Destination:=Range("E2:I" & LastRow)
    End With

    ThisWorkbook.Sheets("Output").Select
    Cells.ClearContents
    Range("A2").Select

    For i = 2 To LastRow
        For j = 1 To Sheets(1).Range("I" & i).Value
            ActiveCell.Value = Sheets(1).Range("A" & i).Value
            ActiveCell.Offset(, 1).Value = Sheets(1).Range("B" & i).Value
            ActiveCell.Offset(, 2).Value = Sheets(1).Range("C" & i).Value
            If j = 1 Then ActiveCell.Offset(, 3).Value = Sheets(1).Range("F" & i).Value
            If j = 2 Then ActiveCell.Offset(, 3).Value = Sheets(1).Range("G" & i).Value
            If j = 3 Then ActiveCell.Offset(, 3).Value = Sheets(1).Range("H" & i).Value
            ActiveCell.Offset(1, 0).Select
        Next
    Next

End Sub

VBA copy values to other sheet with loop

3 Answers3