点击文件名下载附件
代码在text0.xlsm “模块一”里面,text0.xlsm名字不能更改 。子文件夹里的工作簿也能读取比较,请测试。样表里记录的目标工作簿的地址用的是绝对地址。每一次运行,样表都是重新统计,不是加在后面。text0.xlsm里的sheet2必须保留,否则报错,原理是我先将结果写入sheet2,然后在copy出来,然后在将sheet2 清空。
Sub ceshi2214()
Dim filename As String, haha As String, jaja As String, arr1(1 To 100000) As Variant, arr2(1 To 10000) As Variant
Dim i As Integer, k As Integer, j As Integer, kaka As Variant, t As Long, qz1 As Variant, qz2 As Variant
Dim dz1 As String, kk1 As Variant, kk As Variant, t1 As Long, t2 As Long, t3 As Long, t4 As Long, t5 As Long, ls2 As String, t6 As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Workbooks("text0.xlsm").Worksheets(1)
dz1 = .Range("m65536").End(xlUp).Address
kk = Split(dz1, "$")
kk1 = kk(2) '行号
t3 = kk1
'MsgBox kk1
For t1 = 2 To kk1
If .Cells(t1, "m") <> "" Then
Exit For
End If
Next
dz1 = .Range("n65536").End(xlUp).Address
kk = Split(dz1, "$")
kk1 = kk(2) '行号
t4 = kk1
'MsgBox kk1
For t2 = 2 To kk1
If .Cells(t2, "m") <> "" Then
Exit For
End If
Next
'MsgBox t1
'MsgBox t2
't1,t2记录m n 列开始行号 t3,t4分别记录m,n行终止行号
End With
j = 1
k = 1
i = 1
t5 = 2
arr1(i) = ThisWorkbook.Path & "\"
'设置目标文件夹
Do
If k > j Then
Exit Do
End If
jaja = Dir(arr1(k), 16)
'MsgBox "Dir(arr1(k), 16)=" & jaja
Do
jaja = Dir()
'MsgBox "Dir()=" & jaja
If jaja = "" Then
Exit Do
End If
If jaja <> "." And jaja <> ".." Then
' 使用位比较来确定 MyName 代表一目录。
If GetAttr(arr1(k) & jaja) = vbDirectory Then
' 如果它是一个目录,将其地址写入arr1数组
j = j + 1
arr2(j) = arr1(k) & jaja
arr1(j) = arr1(k) & jaja & "\"
'MsgBox "第" & j & "项" & arr1(j)
End If
End If
Loop
k = k + 1
'MsgBox "k为" & k
Loop
'MsgBox j
For t6 = 2 To j
kaka = Dir(arr1(t6))
If kaka <> "" Then
'MsgBox kaka
'MsgBox arr1(t6) & kaka
Workbooks.Open (arr1(t6) & kaka)
qz1 = Range("e6")
qz2 = Range("f6")
ActiveWorkbook.Close
'MsgBox qz1
'MsgBox qz2
ls2 = qz2 & "_" & qz1
For t = t1 To t3
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
t5 = t5 + 1
Exit For
End If
End If
Next
End If
Do
If kaka = "" Then
Exit Do
End If
kaka = Dir
If kaka <> "" Then
'MsgBox kaka
'MsgBox arr1(t6) & kaka
Workbooks.Open (arr1(t6) & kaka)
qz1 = Range("e6")
qz2 = Range("f6")
ls2 = qz2 & "_" & qz1
ActiveWorkbook.Close
For t = t1 To t3
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
t5 = t5 + 1
Exit For
End If
End If
Next
End If
Loop
Next
Workbooks("text0.xlsm").Worksheets(2).Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\样表.xlsx"
ActiveWorkbook.Close
Workbooks("text0.xlsm").Worksheets(2).Cells.ClearContents
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
点击文件名下载附件
代码在text0.xlsm “模块一”里面,text0.xlsm名字不能更改 。子文件夹里的工作簿也能读取比较,请测试。样表里记录的目标工作簿的地址用的是绝对地址。每一次运行,样表都是重新统计,不是加在后面。text0.xlsm里的sheet2必须保留,否则报错,原理是我先将结果写入sheet2,然后在copy出来,然后在将sheet2 清空。
Sub ceshi2214()
Dim filename As String, haha As String, jaja As String, arr1(1 To 100000) As Variant, arr2(1 To 10000) As Variant
Dim i As Integer, k As Integer, j As Integer, kaka As Variant, t As Long, qz1 As Variant, qz2 As Variant
Dim dz1 As String, kk1 As Variant, kk As Variant, t1 As Long, t2 As Long, t3 As Long, t4 As Long, t5 As Long, ls2 As String, t6 As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Workbooks("text0.xlsm").Worksheets(1)
dz1 = .Range("m65536").End(xlUp).Address
kk = Split(dz1, "$")
kk1 = kk(2) '行号
t3 = kk1
'MsgBox kk1
For t1 = 2 To kk1
If .Cells(t1, "m") <> "" Then
Exit For
End If
Next
dz1 = .Range("n65536").End(xlUp).Address
kk = Split(dz1, "$")
kk1 = kk(2) '行号
t4 = kk1
'MsgBox kk1
For t2 = 2 To kk1
If .Cells(t2, "m") <> "" Then
Exit For
End If
Next
'MsgBox t1
'MsgBox t2
't1,t2记录m n 列开始行号 t3,t4分别记录m,n行终止行号
End With
j = 1
k = 1
i = 1
t5 = 2
arr1(i) = ThisWorkbook.Path & "\"
'设置目标文件夹
Do
If k > j Then
Exit Do
End If
jaja = Dir(arr1(k), 16)
'MsgBox "Dir(arr1(k), 16)=" & jaja
Do
jaja = Dir()
'MsgBox "Dir()=" & jaja
If jaja = "" Then
Exit Do
End If
If jaja <> "." And jaja <> ".." Then
' 使用位比较来确定 MyName 代表一目录。
If GetAttr(arr1(k) & jaja) = vbDirectory Then
' 如果它是一个目录,将其地址写入arr1数组
j = j + 1
arr2(j) = arr1(k) & jaja
arr1(j) = arr1(k) & jaja & "\"
'MsgBox "第" & j & "项" & arr1(j)
End If
End If
Loop
k = k + 1
'MsgBox "k为" & k
Loop
'MsgBox j
For t6 = 2 To j
kaka = Dir(arr1(t6))
If kaka <> "" Then
'MsgBox kaka
'MsgBox arr1(t6) & kaka
Workbooks.Open (arr1(t6) & kaka)
qz1 = Range("e6")
qz2 = Range("f6")
ActiveWorkbook.Close
'MsgBox qz1
'MsgBox qz2
ls2 = qz2 & "_" & qz1
For t = t1 To t3
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
t5 = t5 + 1
Exit For
End If
End If
Next
End If
Do
If kaka = "" Then
Exit Do
End If
kaka = Dir
If kaka <> "" Then
'MsgBox kaka
'MsgBox arr1(t6) & kaka
Workbooks.Open (arr1(t6) & kaka)
qz1 = Range("e6")
qz2 = Range("f6")
ls2 = qz2 & "_" & qz1
ActiveWorkbook.Close
For t = t1 To t3
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "m") = qz1 Then
If Workbooks("text0.xlsm").Worksheets(1).Cells(t, "n") = qz2 Then
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "a") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "a")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "b") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "b")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "c") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "c")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "d") = Workbooks("text0.xlsm").Worksheets(1).Cells(t, "d")
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "f") = ls2
Workbooks("text0.xlsm").Worksheets(2).Cells(t5, "h") = arr1(t6) & kaka
t5 = t5 + 1
Exit For
End If
End If
Next
End If
Loop
Next
Workbooks("text0.xlsm").Worksheets(2).Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\样表.xlsx"
ActiveWorkbook.Close
Workbooks("text0.xlsm").Worksheets(2).Cells.ClearContents
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub