VBA копировать значения на другой лист с циклом

Question

Я бы хотел ускорить свою работу с помощью vba, но не знаю, как этого добиться.

Позвольте мне объяснить проблему:

1. У меня есть массив: 12/24, 24/36, 36/48, 48/52
2. Данные из Excel выглядят следующим образом

Первый лист

VBA должен создать на другом листе что-то вроде этого

Второй лист

Возможно ли это?:)

Заранее благодарен за любые советы

Best

Maciej

Answer 1

Попробуйте написать следующее:

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

Вот и все, что нужно сделать. Начните и возвращайтесь, когда у вас возникнут вопросы по кодированию

Answer 2

Это строит массив результатов из массива, содержащего исходные данные.См. Комментарии к коду для объяснения.

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

Answer 3

Хотя Z32A7UL и прав, это не бесплатная служба написания кода, вот вам, мне скучно, не очень интересно, но наверняка работает:

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