Question

我想使用vba加快我的工作，但不知道如何实现。

让我解释一下问题：

我有一个数组：12 / 24、24 / 36、36 / 48、48 / 52
来自excel的数据看起来像这样

First sheet

vba必须在另一个工作表中创建类似这样的内容

Second sheet

有可能吗？：）

在此先感谢您的提示

最佳

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 =“输入” Sheet2 =“输出”

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通过循环将值复制到其他工作表

3 个答案: