从其他工作簿中的相同工作表更新活动工作簿中的工作表时VBA错误

时间:2016-09-16 12:51:44

标签: database vba

VBA-newby需要帮助。

我正在尝试让我的Project用户从另一个相同的文件更新他们的Excel文件。数据可以包括每种类型的数据,包括链接。

然而,我遇到两个问题:

(1)当到达包含指向外部文件的链接的某个单元格时,出现运行时错误13:类型不匹配。

enter image description here

(2)在我的表格中的某些位置,标题会被复制下来,而在其他位置则不会。

enter image description here

我对VBA比较陌生,不知道我的错误在哪里。任何帮助实现我的目标将不胜感激!

Application.ScreenUpdating = False

Dim wbInput As Workbook
Dim wbOutput As Workbook
Set wbOutput = ActiveWorkbook
Dim wsOutputDB As Worksheet
Set wsOutputDB = wbOutput.Worksheets("Meta DB")
Dim wsOutputCriteria As Worksheet
Set wsOutputCriteria = wbOutput.Worksheets("Criteria")
Dim wsOutputSkills As Worksheet
Set wsOutputSkills = wbOutput.Worksheets("Supplier Skills")


Dim strInput As String
Dim ID As Range
Dim IDcolumn As Range
Dim FindID As Range
Dim FindChange
Dim lRowInput As Integer
Dim lRowOutput As Integer
Dim NextRow As Integer
Dim lastcol As Integer
Dim lastcolOutput As Integer
Dim HeaderColumn As Range
Dim FindNewColItem As Range


strInput = Application.GetOpenFilename()
Set wbInput = Workbooks.Open(strInput)

wbInput.Worksheets("Meta DB").Visible = True

lRowInput = wbInput.Worksheets("Meta DB").Range("D" & Rows.Count).End(xlUp).row
lRowOutput = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row
NextRow = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row + 1

'1.0. - - ######################Copy all missing DB-Entries####################
With wbInput.Worksheets("Meta DB")

    lastcol = .Cells(3, Columns.Count).End(xlToLeft).Column
    LastColLetter = Split(wbInput.Worksheets("Meta DB").Cells(3, lastcol).Address, "$")(1)
    lastcolOutput = wsOutputDB.Cells(3, Columns.Count).End(xlToLeft).Column

    '1.1. - - Check if any new Variables have been added
    For Each HeaderColumn In .Range("B3:" & LastColLetter & "3")

        Set FindNewColItem = wsOutputDB.Range("B3:" & LastColLetter & "3").Find(What:=HeaderColumn, LookAt:=xlWhole)

        If FindNewColItem Is Nothing Then

            NewColLetter = Split(HeaderColumn.Address, "$")(1)

            NextCol = lastcolOutput + 1

            wbInput.Worksheets("Meta DB").Range(NewColLetter & "3").Copy Destination:=wsOutputDB.Range(NewColLetter & "3")

            NextCol = NextCol + 1

        End If

    Next HeaderColumn


    '1.2. - - Check if there are any new Entries to the Database
    For Each ID In .Range("D4:D" & lRowInput)

        Set FindID = wsOutputDB.Range("D4:D" & lRowOutput).Find(What:=ID, LookIn:=xlValues, LookAt:=xlWhole)

        '1.2.1. - - If ID is a new Entry, simply add it to our file, else...
        If FindID Is Nothing Then

            NewIDrow = Split(ID.Address, "$")(2)

            wbInput.Worksheets("Meta DB").Range("B" & NewIDrow & ":" & LastColLetter & NewIDrow).Copy Destination:=wsOutputDB.Range("B" & NextRow & ":" & LastColLetter & NextRow)

            NextRow = NextRow + 1

        Else
        '1.2.2. - - If ID already exists, check for Updates of any Information

            For Each IDcolumn In .Range("B" & ID.row & ":" & LastColLetter & ID.row)

                Set FindChange = wsOutputDB.Range("B" & FindID.row & ":" & LastColLetter & FindID.row).Find(What:=IDcolumn)

                If FindChange Is Nothing Then

                    ColLetter = Split(IDcolumn.Address, "$")(1)

                    wbInput.Worksheets("Meta DB").Range(ColLetter & ID.row).Copy Destination:=wsOutputDB.Range(ColLetter & FindID.row)

                End If

            Next IDcolumn

        End If

    Next ID

End With

0 个答案:

没有答案