奖励100元辛苦费，请你做个软件

15824962903a

qq:1558449188.由于文件过大，只是截取一部分加以说明要求。 复件1.rar (63.75 KB, 下载次数: 115)

2018-8-22 17:45 上传

点击文件名下载附件

hefuqing

100美元？太难了

chxw68

比较有意思的一道题目。

小花鹿

理解能力差，看不懂                                                                                                     

chaohuahch

确实很有意思的一道题目，感觉如果要做的话，做好能选择区域，而不是用颜色来判断区域。

一把小刀闯天下

'花了几分钟看懂了

'你漏了J列吧，用0填充的

Option Explicit

Sub test()
  Dim arr, i, j, jj, n
  arr = [z104:ae107]
  For j = 4 To 36
    If Cells(116, j) = "0" Then Cells(116, j) = vbNullString
  Next
  For jj = 1 To 33
    n = 0
    For i = 1 To UBound(arr, 1)
      For j = 1 To UBound(arr, 2)
        If Len(arr(i, j)) > 0 And Len(Cells(111 + i, (jj - 1) + j)) > 0 Then n = n + 1
    Next j, i
    If n > 1 Then Cells(116, jj + 3) = "0"
  Next
End Sub

excelvlookup

Sub QQ378638653()
ar = Range("a112:al115")
br = Range("z104:ae107")
ReDim cr(1 To UBound(ar, 2) - UBound(br, 2) + 1, 1 To UBound(br), 1 To UBound(br, 2))
ReDim arr(1 To 1, 1 To UBound(cr))
For i = 1 To UBound(cr)
    jh = 0: n = 0
    For j = 1 To UBound(br)
        For k = i To i + UBound(br, 2) - 1
            cr(i, j, k - i + 1) = ar(j, k)
            If br(j, k - i + 1) <> "" And cr(i, j, k - i + 1) <> "" Then
                n = n + 1
            End If
            If n > 1 Then
                jh = 1
                arr(1, i) = 1
                Exit For
            End If
        Next
        If jh = 1 Then Exit For
    Next
Next
Range("d127").Resize(1, UBound(cr)) = arr
End Sub
先上一段臭的代码，有意会给你全新的算法，效率远超此段代码

liucqa

excelvlookup 发表于 2018-8-22 22:09
Sub QQ378638653()
ar = Range("a112:al115")
br = Range("z104:ae107")

你这样不好，显得很low。

发个优秀的代码既不会让你倾家荡产，也不会让你富可敌国，不要这样红果果的等money

jaren

呵，有点意思。

lsdongjh

没有难度