[已解决]选定文件获取数据

lsyong

请老师帮忙写一下代码，实现下面功能
工作表“DB” ，从第4行开始，根据下面关系，右边的  I 列 到 P 列， 获取对应的数据。

E:\FP-MO\MO-A\文件夹内 有工作表"DB"

F:\2022年MO\MO\文件夹内 有 PKG220615.xlsx  工作表"PKG"

当工作表“DB”  B列 ,D 列  等于  工作表"PKG" B 列 , C 列  时

工作表"DB"  I 列=工作表"PKG"  D 列
工作表"DB"  J 列=工作表"PKG"  E 列
工作表"DB"  K 列=工作表"PKG"  F 列
工作表"DB"  L 列=工作表"DB"  E 列 大于等于工作表"PKG"  G 列时,等于作表"PKG"  G 列，工作表"DB"  E 列 小于工作表"PKG"  G 列时，等于工作表"DB"  E 列。
工作表"DB"  M 列=取整（工作表"DB"  E 列 /工作表"PKG"  I 列）
工作表"DB"  N 列=向上取整（工作表"DB"  E 列 /工作表"PKG"  I 列）
工作表"DB"  O 列=工作表"DB"  E 列 大于等于工作表"PKG"  I 列时，等于工作表"PKG"  I 列，工作表"DB"  E 列 小于工作表"PKG"  I 列时，等于工作表"DB"  E 列
工作表"DB"  P 列=取整（工作表"DB"  E 列 /工作表"PKG"  I 列）

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-8-24 12:35

简单写了下，可能有误！文件地址请自行修改。

Sub 拷贝()
    Dim d As Object
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim Ar, Br, R, f, X, K
    Set d = CreateObject("scripting.dictionary")
    Set Sh = ActiveSheet
    f = Dir(ThisWorkbook.Path & "\PKG220616.xlsx")
    If f = "" Then MsgBox "【PKG220616】文件不存在": Exit Sub
    Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
    With Wb.Worksheets("PKG")
        Ar = .Range("A1:S" & .Cells(Rows.Count, 2).End(xlUp).Row)
        For R = 1 To UBound(Ar)
            d(Ar(R, 2) & "-" & Ar(R, 3)) = R
        Next R
    End With
    With Sh
        Br = Sh.[a1].CurrentRegion
        For X = 4 To UBound(Br)
            If d.exists(Br(X, 2) & "-" & Br(X, 4)) Then
                K = d(Br(X, 2) & "-" & Br(X, 4))
                Br(X, 9) = Ar(K, 4): Br(X, 10) = Ar(K, 5): Br(X, 11) = Ar(K, 6)
                If Br(X, 5) < Ar(K, 7) Then Br(X, 12) = Br(X, 5) Else Br(X, 12) = Ar(K, 7)
                Br(X, 13) = Int(Br(X, 5) / Ar(K, 9))
                Br(X, 14) = Application.RoundUp(Br(X, 5) / Ar(K, 9), 0)
                If Br(X, 5) < Ar(K, 9) Then Br(X, 15) = Br(X, 5) Else Br(X, 15) = Ar(K, 9)
                Br(X, 16) = Int(Br(X, 5) / Ar(K, 9))
            End If
        Next X
    End With
    Wb.Close True
    Sh.[a1].CurrentRegion = Br
    Set Wb = Nothing
    Set Sh = Nothing
End Sub

跳转到最佳答案楼层

我行我速2008

附件都没有，让人如何帮你。

lsyong

我行我速2008 发表于 2022-8-23 19:13
附件都没有，让人如何帮你。

不好意思，忘了，现在补上了。

我行我速2008

简单写了下，可能有误！文件地址请自行修改。

Sub 拷贝()
    Dim d As Object
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim Ar, Br, R, f, X, K
    Set d = CreateObject("scripting.dictionary")
    Set Sh = ActiveSheet
    f = Dir(ThisWorkbook.Path & "\PKG220616.xlsx")
    If f = "" Then MsgBox "【PKG220616】文件不存在": Exit Sub
    Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
    With Wb.Worksheets("PKG")
        Ar = .Range("A1:S" & .Cells(Rows.Count, 2).End(xlUp).Row)
        For R = 1 To UBound(Ar)
            d(Ar(R, 2) & "-" & Ar(R, 3)) = R
        Next R
    End With
    With Sh
        Br = Sh.[a1].CurrentRegion
        For X = 4 To UBound(Br)
            If d.exists(Br(X, 2) & "-" & Br(X, 4)) Then
                K = d(Br(X, 2) & "-" & Br(X, 4))
                Br(X, 9) = Ar(K, 4): Br(X, 10) = Ar(K, 5): Br(X, 11) = Ar(K, 6)
                If Br(X, 5) < Ar(K, 7) Then Br(X, 12) = Br(X, 5) Else Br(X, 12) = Ar(K, 7)
                Br(X, 13) = Int(Br(X, 5) / Ar(K, 9))
                Br(X, 14) = Application.RoundUp(Br(X, 5) / Ar(K, 9), 0)
                If Br(X, 5) < Ar(K, 9) Then Br(X, 15) = Br(X, 5) Else Br(X, 15) = Ar(K, 9)
                Br(X, 16) = Int(Br(X, 5) / Ar(K, 9))
            End If
        Next X
    End With
    Wb.Close True
    Sh.[a1].CurrentRegion = Br
    Set Wb = Nothing
    Set Sh = Nothing
End Sub

lsyong

我行我速2008 发表于 2022-8-24 12:35
简单写了下，可能有误！文件地址请自行修改。

Sub 拷贝()

非常感谢，帮忙。