数据按照条件提取导入重复条件数据覆盖

Mark.W

各位大神，附表功能原本用函数完成，但是在实际使用过程中，运行速度非常卡，因此请各位大神帮忙看看，是否可以借助VBA帮忙实现，谢谢！

Mark.W

各位大神在吗？有哪位大神可以帮忙看看呢？

不知道为什么

问题不复杂就是看着那么多，就偷懒了

Mark.W

不知道为什么 发表于 2019-3-19 12:17
问题不复杂就是看着那么多，就偷懒了

呵呵，是个体力活，

Mark.W

自己顶一下，求哪位大侠相助！万分感谢！

Mark.W

顶一下，请大神相助，万分感谢！

Mark.W

附件功能基本实现，也不知道代码写的是否合理，反正效果是达到了，但是还有个问题，同一日期、同一班组数据，假如第一次录入数据错误，第二次重新记录保存时，如何先将对应班组数据表内第一次导入日期数据删除呢？删除后再保存最新数据，请大神帮忙看看如何修改。
Sub 保存()
Dim i As Long, bz As String, rng As Range
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    d(sh.Name) = ""
Next sh
i = 3
bz = Worksheets("sheet1").Cells(i, "F").Value
Do While bz <> ""
If Not d.exists(bz) Then
        p = MsgBox("无该班组信息")
        Exit Sub
        Else
        End If
Dim a As Byte
For a = 3 To 30 Step 1
   Select Case Range("F" & a).Value
          Case Is <> ""
               Sheet1.Range("i" & a).Value = Format$(Now, "HH:MM:SS-YY/M/D")
          Case Else
               Sheet1.Range("i" & a).Value = ""
End Select
Next a
Set rng = Worksheets(bz).Range("A65536").End(xlUp).Offset(1, 0)
Worksheets("sheet1").Cells(i, "A").Resize(1, 9).Copy rng
i = i + 1
bz = Worksheets("sheet1").Cells(i, "F").Value
Loop
End Sub