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 < 4 Then
        MsgBox "请确保数据是从第四行开始"
        Exit Sub
    End If
        
    '分析数据库中提取
    If Len(Dir(basedb)) = 0 Then
        MsgBox "找不到文件：" & vbCrLf & basedb, vbExclamation, "错误"
    Else
        Set wb = GetObject(basedb)
        
        For i = 4 To curlastrow
            '产品批号
            v = curWs.Range("d" & i)
             For Each ws In wb.Worksheets
                '分析库中的行数
                wslastrow = ws.Range("a65536").End(xlUp).Row
                
                For j = 4 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)) = 0 Then
        MsgBox "找不到文件：" & vbCrLf & cpdb, vbExclamation, "错误"
    Else
        Set wb = GetObject(cpdb)

        For i = 4 To curlastrow
            v = curWs.Range("d" & i)
             For Each ws In wb.Worksheets
                
                wslastrow = ws.Range("a65536").End(xlUp).Row
                
                For j = 3 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