时间戳

首页 > 解决方案 > 比较、更新或复制外部报告中的数据

excel - 比较、更新或复制外部报告中的数据

问题描述

我正在尝试比较一个主要的计划文件（我们称之为 Main.xlsm）和我们的 ERP 系统（ERP.xlsm）提供的数据。

我正在寻找：

1）打开一个窗口选择源文件（ERP系统转储）​​。

2) 比较两个文件中 F 列的唯一 ID 值（Main.xlsm 中的 Sheet RAPORT 和 ERP.xlsm 中的 Sheet1），并且：

奖励回合：每次发生上述情况时，在其更改的唯一 ID 的行中的“AL”列中放置一个时间/日期戳。

我尝试了下面的代码（原始版本，我没有更改）。我无法弄清楚如何从上面实现所有目标。

Sub import_tickets()
    'run this when the active file is the main ticket list and the active sheet is the ticket list
    'exported file must be open already, and the ticket list must be the active sheet
    Dim exported_file As String
    exported_file = "exported file.xlsx"
    header_exists = True 'if exported file doesn't have a header, set this to false!
    starting_row = 1
    If header_exists Then starting_row = 2

    Dim first_blank_row As Long
    first_blank_row = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row

    Dim r As Long
    r = starting_row
    Dim found As Range
    cur_ticket_num = Workbooks(exported_file).ActiveSheet.Range("a" & r).Value
    Do While Not cur_ticket_num = ""
        'look for current ticket number in main file
        Set found = Columns("a:a").Find(what:=cur_ticket_num, LookIn:=xlValues, lookat:=xlWhole)
        If found Is Nothing Then
            'add info to end of main file
            write_line_from_export exported_file, r, first_blank_row
            first_blank_row = first_blank_row + 1
        Else
            'overwrite existing line of main file
            write_line_from_export exported_file, r, found.Row
        End If
        r = r + 1
        cur_ticket_num = Workbooks(exported_file).ActiveSheet.Range("a" & r).Value
    Loop
End Sub

Sub write_line_from_export(src_filename As String, src_r As Long, dest_r As Long)
    For c = 1 To 24
        Cells(dest_r, c).Value = Workbooks(src_filename).ActiveSheet.Cells(src_r, c).Value
    Next c
End Sub

标签： excelvba

解决方案

这是一个使用 Dictionary 对象比较两张工作表之间的 ID 列的示例。

Sub import_tickets()

  Dim sERPFileName As String
  Dim wbERP As Workbook, wsERP As Worksheet
  Dim wbMain As Workbook, wsMain As Worksheet
  Dim r, startrow, lastrow As Long
  Dim ID
  Dim dictERP
  Set dictERP = CreateObject("Scripting.Dictionary")

  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Show
    sERPFileName = .SelectedItems(1)
  End With

  Application.ScreenUpdating = False

  ' process ERP workbook
  Set wbERP = Workbooks.Open(sERPFileName, , xlReadOnly)
  Set wsERP = wbERP.Sheets("Sheet1")
  startrow = 2 ' assume has header
  lastrow = wsERP.Cells(Rows.Count, "F").End(xlUp).Row

  For r = startrow To lastrow
   ID = wsERP.Range("F" & r).Value
   If dictERP.exists(ID) Then
     MsgBox "Duplicate ID (" & ID & ") found in " & sERPFileName
   Else
     dictERP.Add ID, r
   End If
  Next r

  ' process MAIN workbook
  Set wbMain = ThisWorkbook
  Set wsMain = wbMain.Sheets("RAPORT")
  startrow = 2 ' assume has header
  lastrow = wsMain.Cells(Rows.Count, "F").End(xlUp).Row

  For r = startrow To lastrow
   ID = wsMain.Range("F" & r).Value
   If dictERP.exists(ID) Then
     ' update
     wsERP.Rows(dictERP(ID)).Columns("A:AK").Copy wsMain.Range("A" & r)
     wsMain.Range("L" & r) = "Updated " & Now
     dictERP.Remove (ID)
   Else
     ' set col R = 0
     wsMain.Range("R" & r).Value = 0
     wsMain.Range("L" & r) = "No Change " & Now
   End If
  Next r

  ' add from ERP those not matched
  If dictERP.Count > 0 Then
    For Each ID In dictERP.keys
      r = dictERP(ID)
      lastrow = lastrow + 1
      wsERP.Rows(r).Columns("A:AK").Copy wsMain.Range("A" & lastrow)
      wsMain.Range("L" & lastrow) = "Added " & Now
    Next
  End If

  wbERP.Close
  Application.ScreenUpdating = True

  If dictERP.Count Then
    MsgBox dictERP.Count & " rows added"
  Else
    MsgBox "Done"
  End If
End Sub

推荐阅读