[已解决]VBA怎么指定删除部分数据

minstatey

各位大神，求帮忙看下这种VBA怎么写。每天数据量有点大，不能直接删除重复项，直接删的有部分订单编号为空白的数据会出现错误。每天耗费的时间有点多，求大神帮忙看看

最佳答案

月排行榜 / 总排行榜

风林火山

2022-11-22 15:43

1. Sub TEST()
   
2.     Dim d, k As Integer, str As String, arr, brr(), i As Integer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1:b" & Sheet1.Range("b1000").End(3).Row)
   
5.     For k = 2 To UBound(arr)
   
6.         If arr(k, 1) = "" Then arr(k, 1) = arr(k - 1, 1)
   
7.         str = arr(k, 1) & "," & arr(k, 2)
   
8.         If d.exists(str) = False Then
   
9.             d(str) = ""
   
10.             i = i + 1
    
11.             ReDim Preserve brr(1 To 2, 1 To i)
    
12.             brr(1, i) = arr(k, 1)
    
13.             brr(2, i) = arr(k, 2)
    
14.         End If
    
15.     Next k
    
16.     Sheet2.Range("a1:b1") = Array("订单号", "商品标题")
    
17.     Sheet2.Columns(1).NumberFormatLocal = "@"
    
18.     Sheet2.Range("a2").Resize(i, 2) = Application.Transpose(brr)
    
19.    
    
20. End Sub

复制代码

跳转到最佳答案楼层

风林火山

1. Sub TEST()
   
2.     Dim d, k As Integer, str As String, arr, brr(), i As Integer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1:b" & Sheet1.Range("b1000").End(3).Row)
   
5.     For k = 2 To UBound(arr)
   
6.         If arr(k, 1) = "" Then arr(k, 1) = arr(k - 1, 1)
   
7.         str = arr(k, 1) & "," & arr(k, 2)
   
8.         If d.exists(str) = False Then
   
9.             d(str) = ""
   
10.             i = i + 1
    
11.             ReDim Preserve brr(1 To 2, 1 To i)
    
12.             brr(1, i) = arr(k, 1)
    
13.             brr(2, i) = arr(k, 2)
    
14.         End If
    
15.     Next k
    
16.     Sheet2.Range("e1:f1") = Array("订单号", "商品标题")
    
17.     Sheet2.Columns(5).NumberFormatLocal = "@"
    
18.     Sheet2.Range("e2").Resize(i, 2) = Application.Transpose(brr)
    
19.    
    
20. End Sub

复制代码

minstatey

风林火山 发表于 2022-11-22 14:17

谢谢大神。这个办法可以，但是能让数据直接显示在原数据的位置吗？我刚试着想改动到表1位置，但是之前的多数据多些，更新后的数据粘贴在原位置会混在一起。

风林火山

1. Sub TEST()
   
2.     Dim d, k As Integer, str As String, arr, brr(), i As Integer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1:b" & Sheet1.Range("b1000").End(3).Row)
   
5.     For k = 2 To UBound(arr)
   
6.         If arr(k, 1) = "" Then arr(k, 1) = arr(k - 1, 1)
   
7.         str = arr(k, 1) & "," & arr(k, 2)
   
8.         If d.exists(str) = False Then
   
9.             d(str) = ""
   
10.             i = i + 1
    
11.             ReDim Preserve brr(1 To 2, 1 To i)
    
12.             brr(1, i) = arr(k, 1)
    
13.             brr(2, i) = arr(k, 2)
    
14.         End If
    
15.     Next k
    
16.     Sheet2.Range("a1:b1") = Array("订单号", "商品标题")
    
17.     Sheet2.Columns(1).NumberFormatLocal = "@"
    
18.     Sheet2.Range("a2").Resize(i, 2) = Application.Transpose(brr)
    
19.    
    
20. End Sub

复制代码

哥儿-

1. Sub test()
   
2.     Dim vArr, brr, dic As Object
   
3.     Dim i%, j%, n%, k, s, m
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     vArr = Sheet1.Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(vArr)
   
7.         If Len(vArr(i, 1)) Then
   
8.             n = i
   
9.             If Not dic.exists(vArr(i, 1)) Then Set dic(vArr(i, 1)) = CreateObject("scripting.dictionary")
   
10.             dic(vArr(i, 1))(vArr(i, 2)) = ""
    
11.         Else
    
12.             dic(vArr(n, 1))(vArr(i, 2)) = ""
    
13.         End If
    
14.     Next i
    
15.     ReDim brr(1 To UBound(vArr), 1 To 2)
    
16.     For Each k In dic.keys
    
17.         For Each s In dic(k).keys
    
18.             j = j + 1
    
19.             m = m + 1
    
20.             If j = 1 Then brr(m, 1) = k
    
21.             brr(m, 2) = s
    
22.         Next s
    
23.         j = 0
    
24.     Next
    
25.     Sheet1.Range("A1").CurrentRegion.Offset(1).ClearContents
    
26.     Sheet1.Range("A2").Resize(UBound(brr), 2).NumberFormatLocal = "@"
    
27.     Sheet1.Range("A2").Resize(UBound(brr), 2) = brr
    
28. End Sub

复制代码

哥儿-

1. Sub test()
   
2.     Dim vArr, brr, i%, j%, n%
   
3.     vArr = Sheet1.Range("A1").CurrentRegion
   
4.     ReDim brr(1 To UBound(vArr), 1 To 2)
   
5.     For i = 1 To UBound(vArr)
   
6.         If Len(vArr(i, 1)) = 0 Then vArr(i, 1) = vArr(i - 1, 1)
   
7.     Next i
   
8.     For i = 1 To UBound(vArr)
   
9.         For j = i + 1 To UBound(vArr)
   
10.             If vArr(i, 1) = vArr(j, 1) And vArr(i, 2) = vArr(j, 2) Then vArr(j, 2) = "": vArr(j, 1) = ""
    
11.         Next j
    
12.         If Len(vArr(i, 1)) Then n = n + 1: brr(n, 1) = vArr(i, 1): brr(n, 2) = vArr(i, 2)
    
13.     Next
    
14.     Sheet1.Columns("A:B").Clear
    
15.     Sheet1.Columns(1).NumberFormatLocal = "@"
    
16.     Sheet1.Range("A1").Resize(UBound(brr), 2) = brr
    
17. End Sub
    

复制代码