|
本帖最后由 duquancai 于 2017-9-24 12:32 编辑
Sub shishi()
Dim d As Object, w As Workbook, f$, ph$, arr, brr(1 To 1000, 1 To 8)
ph = ThisWorkbook.Path
k1 = "'" & [h1]: k2 = "'" & [h2]: k3 = [i1]: k4 = [i2]
f = Dir(ph & "\" & "*.xls*")
Set d = CreateObject("Scripting.Dictionary")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set w = GetObject(ph & "\" & f)
arr = w.Sheets(1).Range("a1:g" & w.Sheets(1).Cells(w.Sheets(1).Rows.Count, "g").End(3).Row)
d.RemoveAll
For i = 1 To UBound(arr)
If Not d.exists("'" & arr(i, 7)) Then
d("'" & arr(i, 7)) = i
Else
d("'" & arr(i, 7)) = d("'" & arr(i, 7)) & "," & i
End If
Next
w.Close 0
If d.exists(k1) And d.exists(k2) Then
y1 = Split(d(k1), ","): y2 = Split(d(k2), ",")
For m = 0 To UBound(y2)
For n = 0 To UBound(y1)
s1 = 0: s2 = 0
If y2(m) - y1(n) = 1 Then
For r = 1 To UBound(arr, 2) - 1
s1 = s1 + arr(y1(n), r)
s2 = s2 + arr(y2(m), r)
Next
If s1 = k3 And s2 = k4 Then
x = x + 2
For g = 1 To UBound(arr, 2) - 1
brr(x - 1, g) = arr(y1(n), g)
brr(x - 1, 7) = f: brr(x - 1, 8) = y1(n)
brr(x, g) = arr(y2(m), g)
brr(x, 7) = f: brr(x, 8) = y2(m)
Next
End If
End If
Next
Next
End If
End If
f = Dir
Loop
Range("s1").Resize(1000, 8) = brr
End Sub
|
|