Question

基本上我正在处理一个excel文档，如果它们匹配，它会将此工作簿中的值复制到另一个工作簿中。因此，如果它们具有相同的ID并且为“是”，则更新字段。但是在某些情况下，可能是我在复制到的工作簿中不存在该ID，但如果存在“是”，我想将其添加到下一个空行。

以下是我到目前为止的内容

Dim fpath As String
Dim owb As Workbook
Dim thisone As String
Dim Siteref(1000) As String, siteref2(1000) As String, sitename(1000) As String, sitename2(1000) As String



fpath = "my file path"


Set owb = Application.Workbooks.Open(fpath) 'open location and file

Dim Master As Worksheet 'declare both
Dim Slave As Worksheet


Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying too
Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in

For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
For j = 1 To 1000 '(the master sheet)

If Master.Cells(j, 2).Value = "" Then
GoTo lastline
End If ' if ID cell is blank jump to last line

   If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And Master.Cells(j, 65).Value = "Yes" Then
       Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value 'If the ID equals that in the slave sheet and there is a yes ticked the copy address

  End If

lastline:

Next
Next


MsgBox ("Data Transfer Successful")




Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True

ThisWorkbook.Save
ThisWorkbook.Close 'save and close it

Answer 1

试试这个，让我知道它是否有效。我没有经过测试就把它写成了“盲人”。所以，我不完全确定它会起作用：

Dim bolFound As Boolean
Dim lngLastRow As Long

Dim fpath As String
Dim owb As Workbook

Dim Master As Worksheet 'declare both
Dim Slave As Worksheet

fpath = ActiveWorkbook.Path
Set owb = Application.Workbooks.Open(fpath) 'open location and file

Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in
Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying too
'
lngLastRow = Slave.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For j = 1 To 1000 '(the master sheet)
    bolFound = False
    For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
        If Trim(Master.Cells(j, 2).Value2) = vbNullString Then Exit For 'if ID cell is blank jump to last line
        If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And _
            Master.Cells(j, 65).Value = "Yes" Then
                Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value 'If the ID equals that in the slave sheet and there is a yes ticked the copy address
                bolFound = True
        End If
    Next
    If bolFound = False And _
        Master.Cells(j, 65).Value = "Yes" Then
            Slave.Cells(lngLastRow, 4).Value = Master.Cells(j, 18).Value  'adding the new entry to the list
            lngLastRow = lngLastRow + 1
    End If
Next

MsgBox ("Data Transfer Successful")

Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True

ThisWorkbook.Save
ThisWorkbook.Close 'save and close it

Answer 2

未经测试。

Dim fpath As String
Dim owb As Workbook
Dim thisone As String
Dim Siteref(1000) As String, siteref2(1000) As String, sitename(1000) As String, sitename2(1000) As String
Dim lastRow As Long

fpath = "my file path"
Set owb = Application.Workbooks.Open(fpath) 'open location and file

Dim Master As Worksheet 'declare both
Dim Slave As Worksheet

Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying to
Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in

For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
    For j = 1 To 1000 '(the master sheet)

        If Master.Cells(j, 2).Value = "" Then
            Exit For
        End If ' if ID cell is blank jump to last line

        If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And Master.Cells(j, 65).Value = "Yes" Then
            'If the ID equals that in the slave sheet and there is a yes ticked the copy address
            Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value
        End If

        If Master.Cells(j, 65).Value = "Yes" Then
            lastRow = Slave.Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row
            'if yes found, copy value
            Slave.Cells(lastRow + 1, 4).Value = Master.Cells(j, 18).Value
        End If
    Next
Next

MsgBox ("Data Transfer Successful")

Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True

ThisWorkbook.Save
ThisWorkbook.Close 'save and close it

如果数据不存在，请添加到列表

2 个答案: