VBA 练习－从两个库中调用数据到活动表中

练习VBA

Sub 填报入库单()

    Dim basedb As String, cpdb As String, wb As Workbook, ws As Worksheet, curWs As Worksheet, v As String

    On Error Resume Next

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    basedb = "D:\基础库\分析数据.xlsx"

    cpdb = "D:\基础库\成品抽检信息.xlsx"

    Set curWs = ActiveSheet
    '当前活动表的行数
    curlastrow = curWs.Range("d6556").End(xlUp).Row

    If curlastrow <  Then
        MsgBox "请确保数据是从第四行开始"
        Exit Sub
    End If

    '分析数据库中提取
    If Len(Dir(basedb)) =  Then
        MsgBox "找不到文件：" & vbCrLf & basedb, vbExclamation, "错误"
    Else
        Set wb = GetObject(basedb)

        For i =  To curlastrow
            '产品批号
            v = curWs.Range("d" & i)
             For Each ws In wb.Worksheets
                '分析库中的行数
                wslastrow = ws.Range("a65536").End(xlUp).Row

                For j =  To wslastrow
                    If ws.Range("a" & j) = v Then
                        curWs.Range("O" & i & ":U" & i) = ws.Range("C" & j & ":I" & j).Value
                        curWs.Range("X" & i) = ws.Range("N" & j)
                        curWs.Range("G" & i) = Range("X" & i) & Range("Y" & i)
                         Exit For
                    End If
                Next
            Next
        Next
        wb.Close
    End If

    '成品抽检信息中提取
      If Len(Dir(cpdb)) =  Then
        MsgBox "找不到文件：" & vbCrLf & cpdb, vbExclamation, "错误"
    Else
        Set wb = GetObject(cpdb)

        For i =  To curlastrow
            v = curWs.Range("d" & i)
             For Each ws In wb.Worksheets

                wslastrow = ws.Range("a65536").End(xlUp).Row

                For j =  To wslastrow
                    If ws.Range("a" & j) = v Then

                        curWs.Range("V" & i) = ws.Range("Q" & j)

                        Exit For
                    End If
                Next
            Next
        Next
        wb.Close
    End If

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

    '关闭工具库
    Windows("工具库.xlsm").Activate
    ActiveWindow.Close False

End Sub