求段VBA 代码，要求在文件中。如被采用有小偿。

哈哈900

请各位大神出手相助。
万分感谢。

哈哈900

请群友关注呀！！！

3190496160

Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim rn As Range, rng As Range
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "收入.xlsx")
If f = "" Then MsgBox "找不到收入工作簿！": End
With Sheets("总表")
    yf = .[i1]
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets("在手")
        Set rn = .Rows(5).Find(yf, , , , , , 1)
        If rn Is Nothing Then MsgBox "在手中找不到" & yf: End
        h = rn.Column
        zs = .Cells(32, h)
    End With
    With wb.Worksheets("其他")
        Set rn = .Rows(4).Find(yf, , , , , , 1)
        If rn Is Nothing Then MsgBox "其他中找不到" & yf: End
        y = rn.Column
        qt = .Cells(5, y)
    End With
    wb.Close False
    lh = Val(yf) + 13
    .Cells(24, lh) = .Cells(24, lh - 1) + zs + qt
    Set f = Nothing
    f = Dir(lj & "其他费用.xlsx")
    If f = "" Then MsgBox "找不到其他费用工作簿！": End
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets(1)
        ar = .[c3:n7]
        br = .[c14:n17]
    End With
    wb.Close False
    .[n35].Resize(UBound(ar), UBound(ar, 2)) = ar
    .[n54].Resize(UBound(br), UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助文件-1.rar (98.07 KB, 下载次数: 14)

2024-5-11 15:15 上传

点击文件名下载附件

哈哈900

3190496160 发表于 2024-5-11 15:14
Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

此代码只能填入指定月份的数。后面的月份没法填入呀。
麻烦再优化下可以吗？
万分感谢。

哈哈900

3190496160 发表于 2024-5-11 15:15

此代码只能填入指定月份的数。后面的月份没法填入呀。
麻烦再优化下可以吗？
万分感谢。

gwjkkkkk

标记一下。。。

EHGOOD

测试下看。

3190496160

Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim rn As Range, rng As Range
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "收入.xlsx")
If f = "" Then MsgBox "找不到收入工作簿！": End
With Sheets("总表")
    yf = .[i1]
    lh = Val(yf) + 1
     .Range(.Cells(24, lh + 12), .Cells(24, 25)) = Empty
    arr = .Range("m15:y24")
    For j = lh To UBound(arr, 2)
        d(arr(1, j)) = j
    Next j
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets("在手")
        r = .Cells(Rows.Count, 13).End(xlUp).Row
        ar = .Range("n5:ab" & r)
        For j = 1 To UBound(ar, 2)
            If ar(1, j) <> "" Then
                If InStr(ar(1, j), "月") > 0 Then
                    w = Val(ar(1, j)) & "月"
                    llh = d(w)
                    If llh <> "" Then
                        arr(UBound(arr), llh) = ar(UBound(ar), j)
                    End If
                End If
            End If
        Next j
    End With
    With wb.Worksheets("其他")
        ar = .Range("j4:x5")
        For j = 1 To UBound(ar, 2)
            If ar(1, j) <> "" Then
                If InStr(ar(1, j), "月") > 0 Then
                    w = Val(ar(1, j)) & "月"
                    llh = d(w)
                    If llh <> "" Then
                        arr(UBound(arr), llh) = arr(UBound(arr), llh) + ar(UBound(ar), j)
                    End If
                End If
            End If
        Next j
    End With
    wb.Close False
    For j = lh To UBound(arr, 2)
        arr(UBound(arr), j) = arr(UBound(arr), j) + arr(UBound(arr), j - 1)
    Next j
    .Cells(24, 13).Resize(1, UBound(arr, 2)) = Application.Index(arr, UBound(arr), 0)
    Set f = Nothing
    f = Dir(lj & "其他费用.xlsx")
    If f = "" Then MsgBox "找不到其他费用工作簿！": End
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets(1)
        ar = .[c3:n7]
        br = .[c14:n17]
    End With
    wb.Close False
    .[n35].Resize(UBound(ar), UBound(ar, 2)) = ar
    .[n54].Resize(UBound(br), UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助文件-1.rar (99.05 KB, 下载次数: 10)

2024-5-12 09:21 上传

点击文件名下载附件