VBA把字典改写成 纯数组方法 按列计算遗漏值

laoau138

today0427 发表于 2017-2-9 22:59
说明咱俩水平差不多

错了，你比我强N倍

today0427

不能 如果看不懂 留言明天给你写注释 现在晚了我关电脑了

today0427

相当于把出现过的数字那个空用0来占位 表示出现了

laoau138

today0427 发表于 2017-2-9 23:03
不能 如果看不懂 留言明天给你写注释 现在晚了我关电脑了

好，你明天写注释

如此简洁高明的写法，只有你想得到

today0427

呦小样 会夸人了啊 有进步！加油！

laoau138

today0427 发表于 2017-2-9 22:59
说明咱俩水平差不多

昨天看见你在回答  ADO

相信这段时间，你的VBA神功一定增进了不少

today0427

咳咳咳 客气客气 还需不断努力！共勉！

laoau138

today0427 发表于 2017-2-9 23:06
呦小样 会夸人了啊 有进步！加油！

没有夸奖啊， 你确实进步了

下面几个代码，都比不上你


Sub test()
Dim SArr1(), SArr2, Tarr(), i%, j%, n%
SArr2 = [k10:aq10]
n = [c11].End(xlDown).Row
ReDim SArr1(11 To n)
ReDim Tarr(11 To n, 1 To 33)
For i = 11 To n
  For j = 3 To 8
    SArr1(i) = SArr1(i) & "," & Format(Cells(i, j), "00")
  Next
Next
For i = 11 To n
  For j = 1 To 33
    If i = 11 Then
       Tarr(i, j) = IIf(InStr(1, SArr1(i), "," & Format(SArr2(1, j), "00")) > 0, 0, 1)
    Else
       Tarr(i, j) = IIf(InStr(1, SArr1(i), "," & Format(SArr2(1, j), "00")) > 0, 0, 1 + Tarr(i - 1, j))
    End If
  Next
Next
[k11].Resize(n - 10, 33) = Tarr
End Sub



Sub pengyx()
Dim rw%, ar, br, i%, s%, j%
[k11:aq11] = 1
rw = Sheet1.Range("c" & Rows.Count).End(3).Row
ar = Sheet1.Range("k11:aq" & rw)
br = Sheet1.Range("c11:h" & rw)
For i = 1 To UBound(br, 2)
    ar(1, br(1, i)) = 0
Next
For i = 2 To UBound(ar)
    s = 1
    For j = 1 To 33
        If br(i, s) = j Then
            ar(i, j) = 0
            If s < 6 Then s = s + 1
        Else
            ar(i, j) = ar(i - 1, j) + 1
        End If
    Next
Next
Sheet1.Range("k11").Resize(UBound(ar), 33) = ar
End Sub


Sub Command1_Click()
  Dim arrSrc, arrDest, arrFlag
  Dim lStartr As Long
  Dim lEndr As Long
  Dim lr As Long
  Dim lc As Long
  lStartr = 11
  lEndr = Range("B65536").End(xlUp).Row
  If lEndr < lStartr Then Exit Sub
  Range("K" & lStartr & ":AQ" & lEndr).ClearContents
  arrSrc = Range("C" & lStartr & ":H" & lEndr)
  arrDest = Range("K" & lStartr & ":AQ" & lEndr)
  arrFlag = arrDest
  For lr = 1 To lEndr - lStartr + 1
    For lc = 1 To 6
      arrFlag(lr, arrSrc(lr, lc)) = 1
    Next lc
    If lr = 1 Then
      For lc = 1 To 33
        If arrFlag(lr, lc) = 0 Then
          arrDest(lr, lc) = 1
        Else
          arrDest(lr, lc) = 0
        End If
      Next lc
    Else
      For lc = 1 To 33
        If arrFlag(lr, lc) = 0 Then
          arrDest(lr, lc) = arrDest(lr - 1, lc) + 1
        Else
          arrDest(lr, lc) = 0
        End If
      Next lc
    End If
  Next lr
  Range("K" & lStartr & ":AQ" & lEndr) = arrDest
End Sub

today0427

能看出来我进步了 你也有大进步啊 最关键你现在能加6分了！咱俩也算得上看着对方一点点成长呢吧！来握个手！

laoau138

today0427 发表于 2017-2-9 23:24
能看出来我进步了 你也有大进步啊 最关键你现在能加6分了！咱俩也算得上看着对方一点点成长呢吧！来握个 ...

可爱的today   你还没有睡