VBA比较多个条件满足才能提取

laoau138

VBA比较多个条件满足才能提取

蓝桥玄霜

间隔行数=2

laoau138

蓝桥玄霜 发表于 2016-9-22 13:29
间隔行数=2

间隔行数=2   这个明显不对

1,左右两面同时出现，才能提取，否则不提取

2，间隔行数等于2    左面上下行间隔等于2   右面上下行间隔等于2

同时满足几个条件才能提取

这个有点复杂了

雄鹰2013

有空帮你看看

雄鹰2013

左边显示的是第一区域还是第二区域？
第二区域是第7行开始至剩余的，这个第7行是顺着还是倒着第7行。
感觉题目没表达清楚要干什么。

laoau138

雄鹰2013 发表于 2016-9-30 16:56
左边显示的是第一区域还是第二区域？
第二区域是第7行开始至剩余的，这个第7行是顺着还是倒着第7行。
感 ...

写错一点改正了


第一:分两个数据区, A:E列倒数统计G1=7行,第一数据区(符合条件放右边);
A:E列第11行开始顺数至剩余行数,第二数据区(符合条件放左边)
第二:如果第一数据区(代表左面)某行与第二数据区(代表右面)某行，有G3=1个数字相同,为左右两面对应行连续1次
第三:左右两面对应行连续G6=6次 保留左面2015035与右面2016102这行作为预测
第四:G9控制左右两面数据区，上下行间隔行数G1=1
现在G1=1,所以I11=2015029，I12=2015030； 如果G2=2，I11=2015029，I12=2015031；就这样间隔关系
同时满足四个条件将第一数据区这行提取到左边I11单元格, 将第二数据区这行提取到右边p11单元格
用VBA如何做   按钮控制结果从第20行I列黄底单元格开始输出    I11开始为部分模拟结果

laoau138

雄鹰2013 发表于 2016-9-30 16:56
左边显示的是第一区域还是第二区域？
第二区域是第7行开始至剩余的，这个第7行是顺着还是倒着第7行。
感 ...

Sub 看答案()
On Error Resume Next
g1 = [g1]: [g6] = g1 - 1: g3 = [g3]: g6 = [g6]: g9 = [g9]
m = [a65536].End(3).Row
arr = Range("a" & m - g1 + 1 & ":e" & m)
brr = Range("a11:e" & m - g1)
Range("I11:T65536").ClearContents
For i = 1 To UBound(brr) - g1 * g9
ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
     For j = 1 To UBound(arr) - 1
         s1 = 0
        For x = 3 To 5
           For y = 3 To 5
              If brr(i + (j - 1) * g9, x) = arr(j, y) Then
                 s1 = s1 + 1
                   If s1 = g3 Then Exit For
              End If
           Next
           If s1 = g3 Then Exit For
        Next
        If s1 = g3 Then s2 = s2 + 1 Else s2 = 0: Exit For
     Next
  If s2 = g6 Then
     For j2 = 1 To UBound(arr)
        For x2 = 1 To UBound(arr, 2)
            crr(j2, x2) = brr(i + (j2 - 1) * g9, x2)
        Next
     Next
     m2 = [i65536].End(3).Row
     If m2 < 9 Then m2 = 9
     Cells(m2 + 2, "i").Resize(UBound(arr), 5) = crr
     Cells(m2 + 2, "p").Resize(UBound(arr), 5) = arr
  End If
Next
End Sub

laoau138

雄鹰2013 发表于 2016-9-30 16:56
左边显示的是第一区域还是第二区域？
第二区域是第7行开始至剩余的，这个第7行是顺着还是倒着第7行。
感 ...

大侠这个怎样做

用VBA推算组成平行四边形最后一个数字

http://www.excelpx.com/thread-424828-1-1.html

雄鹰2013

laoau138 发表于 2016-10-2 18:30
Sub 看答案()
On Error Resume Next
g1 = [g1]: [g6] = g1 - 1: g3 = [g3]: g6 = [g6]: g9 = [g9]

Sub 雄鹰()
Dim a, b, c, d
Dim arr, brr, crr
Set dic = CreateObject("scripting.dictionary")
On Error Resume Next
Range("I19:T65536").ClearContents
[g6] = [g1] - 1 '最后一行预测用
a = [g1] '倒数统计多少行
b = [g3] '每行至少有几个数字相同
c = [g6] '连续相同的行数的次数
d = [g9] '上下间隔行数
r = Cells(Rows.Count, 1).End(xlUp).Row '最后一行行号
rr = r - a + 1 '倒数区域的起始行
arr = Range("a" & rr & ":e" & r)
brr = Range("a11:e" & rr - 1)
ReDim crr(1 To UBound(arr), 1 To 5)
For i = 1 To UBound(arr) - 1
     Set dic(i) = CreateObject("scripting.dictionary") '将每行设一个字典
     For j = 3 To 5
         dic(i)(arr(i, j)) = "" '将每行中的数据放入字典中
     Next j
Next i
i = 1
For i = i To UBound(brr)
     x = 1: s = 1: y = i
     Do While x < a
        n = 0 '判断同行相同数据个数
        For j = 3 To 5
            If dic(x).exists(brr(i, j)) Then n = n + 1 '如果某行中有brr中的数据就累加
               crr(s, 1) = brr(i, 1)
               crr(s, 2) = brr(i, 2)
               crr(s, j) = brr(i, j)
        Next j
        If n < b Then x = 1: s = 1: ReDim crr(1 To UBound(arr), 1 To 5): Exit Do
        x = x + 1: i = i + d: s = s + 1
     Loop
     For j = 1 To 5
         crr(s, j) = brr(i, j)
        Next j
     If x = a And crr(s, 1) <> "" Then
        Range("i65536").End(xlUp).Offset(2).Resize(UBound(crr), 5) = crr
        Range("p65536").End(xlUp).Offset(2).Resize(UBound(arr), 5) = arr
     End If
     i = y
Next i
End Sub

雄鹰2013

laoau138 发表于 2016-10-5 19:19
大侠这个怎样做

用VBA推算组成平行四边形最后一个数字

感觉比上面的答案多了一组数据

2016040	2016-2-16	1	4	3			2016096	2016-4-12	3	4	8
2016041	2016-2-17	5	1	9			2016097	2016-4-13	5	3	2
2016042	2016-2-18	7	0	1			2016098	2016-4-14	4	1	4
2016043	2016-2-19	5	5	7			2016099	2016-4-15	2	1	7
2016044	2016-2-20	0	1	0			2016100	2016-4-16	5	5	1
2016045	2016-2-21	6	9	2			2016101	2016-4-17	0	6	1
2016046	2016-2-22	3	8	3			2016102	2016-4-18