找高手帮助匹配EXCEL的数据

yudis98s · 发表于 2020-3-2 14:55

一把小刀闯天下发表于 2020-3-2 14:41
台式电脑也不一定够，可以分段处理。比如有10^6条数据，每次处理10^5条（不出错就可以）。觉得总用时应该 ...

我每次处理少量数据，在三千行以内，没有出错了

一把小刀闯天下 · 发表于 2020-3-2 15:11

yudis98s 发表于 2020-3-2 14:55
我每次处理少量数据，在三千行以内，没有出错了

'我关心的是2个时间，如果成功给我贴上来，当然包括总的数据量

'已修改，1-3工作表中的数据量可以不限，怎么使用看下面的注释，，，

Option Explicit

Const NUM As Long = 5 * 10 ^ 4 '每个字典最多装入的数据条数
Const LINE As Long = 10 ^ 5 '分段读取数据，这里10^5行为一段，如果溢出可以改的更小些，比如5*10^4

Sub test()
  Dim arr(), t As String, i As Long, j As Long, k As Long, kk As Long
  Dim cnt As Long, m As Long, tm As Single, n As Long, ii As Long
  Dim row As Long
  tm = Timer
  With Sheets("4")
arr = .Range("b2:b" & .Cells(Rows.Count, "b").End(xlUp).row).Value
  End With
  ReDim brr(1 To UBound(arr, 1), 1 To 12) As String
  ReDim dic(UBound(arr, 1) / NUM + 1) As Object
  For i = 1 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
  Next
  For i = 1 To UBound(arr, 1)
t = arr(i, 1)
If Len(t) Then
   If m Mod NUM = 0 Then cnt = cnt + 1
   dic(cnt)(t) = i: m = m + 1
End If
  Next
  On Error GoTo errmsg
  For i = 1 To 3
row = Sheets(CStr(i)).Cells(Rows.Count, "b").End(xlUp).row
ReDim pos(1 To row \ LINE + 1, 1 To 2) As Long
For ii = 1 To UBound(pos)
   pos(ii, 1) = (ii - 1) * LINE + 1
   pos(ii, 2) = ii * LINE
   If row <= pos(ii, 2) Then n = ii: pos(ii, 2) = row: Exit For
Next
For ii = 1 To n
   arr = Sheets(CStr(i)).Cells(pos(ii, 1), "b").Resize(pos(ii, 2), 13).Value
   For j = 1 To UBound(arr, 1) - 1
      t = arr(j, 1)
      If Len(t) Then
      For k = 1 To cnt
         If dic(k).exists(t) Then
            m = dic(k)(t)
            For kk = 2 To UBound(arr, 2)
            brr(m, kk - 1) = arr(j, kk)
            Next
            Exit For
         End If
      Next
      End If
   Next
Next
  Next
  Debug.Print Timer - tm
  Sheets("4").[c2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  Debug.Print Timer - tm
  Exit Sub
errmsg:
  MsgBox "Error:" & vbNewLine & "工作表：" & i & vbNewLine & "行数：" & j + 1
End Sub

一把小刀闯天下 · 发表于 2020-3-2 15:14

>3K行就出错？没有这样差的电脑的吧

一般控制在5W行应该没有问题，因为比较有13列，，，

excel海 · 发表于 2020-3-2 15:34

试试

Private Sub Test()
Dim i, j, k, arr, brr, x, y, n
Dim sht As Worksheet
Dim dic
Set dic = CreateObject("scripting.dictionary")
ReDim brr(1 To 1, 1 To 12)
Application.ScreenUpdating = False
x = Timer
For Each sht In Sheets
If sht.Name <> Sheets("4").Name Then
n = sht.Cells(Rows.Count, 2).End(xlUp).Row
arr = sht.Range("b1:n" & n)
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
brr(1, j - 1) = arr(i, j)
Next
dic(arr(i, 1) & "") = brr
Next
End If
Next
With Sheets("4")
n = .Cells(Rows.Count, 2).End(xlUp).Row
arr = .Range("b1:n" & n)
ReDim brr(1 To UBound(arr) - 1, 2 To UBound(arr, 2))
For i = 2 To UBound(arr)
If dic.exists(arr(i, 1) & "") Then
For j = 2 To UBound(brr, 2)
brr(i - 1, j) = dic(arr(i, 1) & "")(1, j - 1)
Next
End If
Next
.Range("c2:n" & n).ClearContents
.Range("c2:n" & n) = brr
End With
MsgBox "用时:" & Timer - x & "s"
Application.ScreenUpdating = True
End Sub

复制代码

yudis98s · 发表于 2020-3-2 15:59

一把小刀闯天下发表于 2020-3-2 15:14
>3K行就出错？没有这样差的电脑的吧

一般控制在5W行应该没有问题，因为比较有13列，，，

4千就会出错，我的是macbook air 4G内存吧

一把小刀闯天下 · 发表于 2020-3-2 16:05

yudis98s 发表于 2020-3-2 15:59
4千就会出错，我的是macbook air 4G内存吧

还好我不喜欢macbook

Const LINE As Long = 10 ^ 5改成

---------------
Const LINE As Long = 3000

yudis98s · 发表于 2020-3-2 16:22

一把小刀闯天下发表于 2020-3-2 15:11
'我关心的是2个时间，如果成功给我贴上来，当然包括总的数据量

'已修改，1-3工作表中的数据量可以不限 ...

Option Explicit

Const NUM As Long = 5 * 10 ^ 4 '每个字典最多装入的数据条数
Const LINE As Long = 10 ^ 5 '分段读取数据，这里10^5行为一段，如果溢出可以改的更小些，比如5*10^4

Sub test()
  Dim arr(), t As String, i As Long, j As Long, k As Long, kk As Long
  Dim cnt As Long, m As Long, tm As Single, n As Long, ii As Long
  Dim row As Long
  tm = Timer
  With Sheets("4")
arr = .Range("b2:b" & .Cells(Rows.Count, "b").End(xlUp).row).Value
  End With
  ReDim brr(1 To UBound(arr, 1), 1 To 12) As String
  ReDim dic(UBound(arr, 1) / NUM + 1) As Object
  For i = 1 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
  Next
  For i = 1 To UBound(arr, 1)
t = arr(i, 1)
If Len(t) Then
   If m Mod NUM = 0 Then cnt = cnt + 1
   dic(cnt)(t) = i: m = m + 1
End If
  Next
  On Error GoTo errmsg
  For i = 1 To 3
row = Sheets(CStr(i)).Cells(Rows.Count, "b").End(xlUp).row
ReDim pos(1 To row \ LINE + 1, 1 To 2) As Long
For ii = 1 To UBound(pos)
   pos(ii, 1) = (ii - 1) * LINE + 1
   pos(ii, 2) = ii * LINE
   If row <= pos(ii, 2) Then n = ii: pos(ii, 2) = row: Exit For
Next
For ii = 1 To n
   arr = Sheets(CStr(i)).Cells(pos(ii, 1), "b").Resize(pos(ii, 2), 13).Value
   For j = 1 To UBound(arr, 1) - 1
      t = arr(j, 1)
      If Len(t) Then
      For k = 1 To cnt
         If dic(k).exists(t) Then
            m = dic(k)(t)
            For kk = 2 To UBound(arr, 2)
            brr(m, kk - 1) = arr(j, kk)
            Next
            Exit For
         End If
      Next
      End If
   Next
Next
  Next
  Debug.Print Timer - tm
  Sheets("4").[c2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  Debug.Print Timer - tm
  Exit Sub
errmsg:
  MsgBox "Error:" & vbNewLine & "工作表：" & i & vbNewLine & "行数：" & j + 1
End Sub

还是你改完的这个，目前是没有出错了，这个改了之后，我目前运行5000行，没有问题，感谢

一把小刀闯天下 · 发表于 2020-3-2 17:55

yudis98s 发表于 2020-3-2 16:22
Option Explicit

Const NUM As Long = 5 * 10 ^ 4 '每个字典最多装入的数据条数

有点问题，刚才没有注意

22楼、27楼：
For j = 1 To UBound(arr, 1) - 1改成

For j = 1 To UBound(arr, 1)

----------------

不然数据有可能会丢失，，，

tcdatongye · 发表于 2020-3-3 14:30

昨天在网上看了下access，发觉导入进去就不需如此麻烦了，速度也就几秒种而已

xinlan6 · 发表于 2020-3-3 16:44

一把小刀闯天下发表于 2020-3-2 15:11
'我关心的是2个时间，如果成功给我贴上来，当然包括总的数据量

'已修改，1-3工作表中的数据量可以不限 ...

请教老师：如果这个工作簿内的几个工作表不是连续的数字作为工作表名称
比如工作表1=北京市，工作表2=上海市，工作表3=广东省，工作表4=待匹配表
该如何修改您的代码呢？
谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 找高手帮助匹配EXCEL的数据

评分

评分

评分