[已解决]EXCEL VBA 根据条件更新某列单元格内容

gemeng25569

sheet1
工号    姓名     日期
2123   张三      2022-01-01
2124   李四      2022-02-23
2245   王五      2022-03-11
2555   徐六      2022-01-14
2455   德胡      2022-02-15
6633   吴吴      2022-02-01

sheet2
工号    姓名     日期
2123   张三      2022-02-20
2124   李四      2022-02-25
6633   吴吴      2022-02-01

2569   夏梅      2022-06-01
如上Sheet1和sheet2两个工作表，
问题1：
如果同一个人，sheet2的日期大于sheet1时，将sheet1后面的日期更新成sheet2的日期，因为数据很多
问题2：
比如Sheet2中
2569   夏梅      2022-06-01    此人不在Sheet1清单中，如果添加至Sheet1表中？

希望VB大师帮忙，感谢！

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-16 18:58

Sub tt()
  On Error Resume Next
  Dim K%, X%, Str$
  Dim Arr, Ar, Cr()
  Dim D
  Set D = CreateObject("scripting.dictionary")
  For K = 1 To 2
    Arr = Sheets(K).Range("A1").CurrentRegion
    For X = 1 To UBound(Arr)
      Str = Arr(X, 1) & "-" & Arr(X, 2)
      If Arr(X, 3) > D(Str) Then D(Str) = Arr(X, 3)
    Next X
  Next K
  Ar = Application.Transpose(Array(D.keys, D.items))
  ReDim Cr(1 To UBound(Ar), 1 To 3)
  For X = 1 To UBound(Ar)
    Cr(X, 1) = Split(Ar(X, 1), "-")(0)
    Cr(X, 2) = Split(Ar(X, 1), "-")(1)
    Cr(X, 3) = Ar(X, 2)
  Next X
  With Sheet2
    .Cells(1, 1).Resize(UBound(Ar), 3) = Cr
  End With
End Sub

跳转到最佳答案楼层

林木水

需求不明确，你自己再组织一下语言，把附件放上去

gemeng25569

确实描述的不清楚
sheet1
工号    姓名     日期
2123   张三      2022-01-01
2124   李四      2022-02-23
2245   王五      2022-03-11
2555   徐六      2022-01-14
2455   德胡      2022-02-15
6633   吴吴      2022-02-01
2569   夏梅      2022-06-01

sheet2
2123   张三      2022-01-01
2124   李四      2022-02-23
6633   吴吴      2022-02-01

sheet2 结果展示
工号    姓名     日期
2123   张三      2022-02-20    ‘日期从2022-01-01更新为2022-02-20
2124   李四      2022-02-25    ‘日期从2022-02-23更新为2022-02-25
6633   吴吴      2022-02-01
2569   夏梅      2022-06-01    ‘sheet1有，sheet2没有此人，将此人添加至Sheet2

hasyh2008

Sub tt()
  On Error Resume Next
  Dim K%, X%, Str$
  Dim Arr, Ar, Cr()
  Dim D
  Set D = CreateObject("scripting.dictionary")
  For K = 1 To 2
    Arr = Sheets(K).Range("A1").CurrentRegion
    For X = 1 To UBound(Arr)
      Str = Arr(X, 1) & "-" & Arr(X, 2)
      If Arr(X, 3) > D(Str) Then D(Str) = Arr(X, 3)
    Next X
  Next K
  Ar = Application.Transpose(Array(D.keys, D.items))
  ReDim Cr(1 To UBound(Ar), 1 To 3)
  For X = 1 To UBound(Ar)
    Cr(X, 1) = Split(Ar(X, 1), "-")(0)
    Cr(X, 2) = Split(Ar(X, 1), "-")(1)
    Cr(X, 3) = Ar(X, 2)
  Next X
  With Sheet2
    .Cells(1, 1).Resize(UBound(Ar), 3) = Cr
  End With
End Sub

gemeng25569

hasyh2008 发表于 2022-6-16 18:58
Sub tt()
  On Error Resume Next
  Dim K%, X%, Str$

感谢hasyh2008，就是这个效果，非常感谢

hasyh2008

gemeng25569 发表于 2022-6-17 07:34
感谢hasyh2008，就是这个效果，非常感谢

认为适合就选为最佳答案，建议数据不要放在原来表格.

gemeng25569

hasyh2008 发表于 2022-6-16 18:58
Sub tt()
  On Error Resume Next
  Dim K%, X%, Str$

好了

gemeng25569

hasyh2008 发表于 2022-6-17 12:02
认为适合就选为最佳答案，建议数据不要放在原来表格.

你好！hasyh2008，

引用这段代码出现另一个问题

比如当Sheet2有100条历史数据时，sheet1有20条新数据，代码运行后会把Sheet2中20条数据给覆盖掉

我的目的是，Sheet2里的数据是历史保存数据，当Shee1数据有新数据就添加，如果有相同人员出现时就更新一下日期

还希望你帮忙看看

我行我速2008

所以不要在原表格中修改数据，要把数据放到新工作表中。

我行我速2008

Sub tt()
   On Error Resume Next
   Dim K%, X%, Str$
   Dim Arr, Ar, Cr()
   Dim D
   Set D = CreateObject("scripting.dictionary")
   For K = 1 To 2
     Arr = Sheets(K).Range("A1").CurrentRegion
     For X = 1 To UBound(Arr)
       Str = Arr(X, 1) & "-" & Arr(X, 2)
       If Arr(X, 3) > D(Str) Then D(Str) = Arr(X, 3)
     Next X
   Next K
   Ar = Application.Transpose(Array(D.keys, D.items))
   ReDim Cr(1 To UBound(Ar), 1 To 3)
   For X = 1 To UBound(Ar)
     Cr(X, 1) = Split(Ar(X, 1), "-")(0)
     Cr(X, 2) = Split(Ar(X, 1), "-")(1)
     Cr(X, 3) = Ar(X, 2)
   Next X
   With Sheet3
     .Cells(1, 1).Resize(UBound(Ar), 3) = Cr
   End With
End Sub