[求助] 如何从明细表转换成客户对帐单？

slyouna

每个月对账单有几百客户，复制粘贴明细账到对账单太繁琐了，求直接明细账生成对账单的方法，附件如下，万分感谢！

excel玉米

做个mark.等答案中。。。。

zmj9151

代码已完成，附件传不上去，如需要加qq657294056发送

excel玉米

excel2003环境下学做，勉强能达到要求。请见附件。
Sub 生成账单()
    Dim arr1,  arr4, i%
    arr1 = Sheet1.Range("a2").CurrentRegion
    m = UBound(arr1): n = UBound(arr1, 2)
    For i = 2 To m
        Application.ScreenUpdating = False
        If (arr1(i + k, 2)) = (arr1(m, 2)) Then Exit For
        If Len(arr1(i, 1)) > 0 And Len(arr1(i + 1, 1)) > 0 Then
            arr1(i, 1) = Replace(arr1(i, 1), "/", "-")
            Dim Wk As Workbook
            Set Wk = Workbooks.Add
            Application.DisplayAlerts = False
            Wk.SaveAs Filename:=ThisWorkbook.Path & "\" & arr1(i, 1) & ".xls"
            Workbooks("对账单.xls").Sheets("对账单").Copy Before:=Workbooks(arr1(i, 1) & ".xls").Sheets(1)
            arr4 = Workbooks("对账单.xls").Sheets("明细账").Range("a" & i + 1 & ":" & "k" & i + 1)
        ElseIf Len(arr1(i, 1)) > 0 And Len(arr1(i + 1, 1)) = 0 Then
            arr1(i, 1) = Replace(arr1(i, 1), "/", "-")
            Set Wk = Workbooks.Add
            Application.DisplayAlerts = False
            Wk.SaveAs Filename:=ThisWorkbook.Path & "\" & arr1(i, 1) & ".xls"
            Workbooks("对账单.xls").Sheets("对账单").Copy Before:=Workbooks(arr1(i, 1) & ".xls").Sheets(1)
            For k = 1 To m Step 1
                If Len(arr1(i + k, 1)) = 0 Then w = w + 1
                If (arr1(i + k, 2)) = (arr1(m, 2)) Then Exit For
                If Len(arr1(i + k, 1)) > 0 Then Exit For
            Next
            arr4 = Workbooks("对账单.xls").Sheets("明细账").Range("a" & i + 1 & ":" & "k" & i + 1 + w)
            w = 0
         ElseIf Len(arr1(i, 1)) = 0 And Len(arr1(i + 1, 1)) = 0 Then GoTo 0
         ElseIf Len(arr1(i, 1)) = 0 And Len(arr1(i + 1, 1)) > 0 Then GoTo 0
         End If
        With GetObject(ThisWorkbook.Path & "\" & arr1(i, 1) & ".xls")
            For j = Worksheets.Count To 1 Step -1
                If Worksheets(j).Name <> "对账单" Then '
                   Worksheets(j).Delete
                End If
            Next
        Application.DisplayAlerts = True
        With Sheets("对账单")
            For p = 1 To UBound(arr4)
                If Len(arr4(p, 1)) > 0 Then .Cells(3, 4) = arr4(p, 1) '客户名称
                If Len(arr4(p, 1)) > 0 Then .Cells(6, 4) = arr4(p, 1) '客户名称
                For u = 2 To 11
                    .Cells(10 + p, u) = arr4(p, u)
                Next
            Next
        End With
        .Close Savechanges:=True
    End With
0
Next
Application.ScreenUpdating = True
MsgBox ("账单已生成！")
End Sub

zmj9151

自动生成明细