|
|
本帖最后由 hahada 于 2014-4-9 17:03 编辑
Sub aaa()
Dim sz(), sz1, SZ2(), myRegExp As Object
On Error Resume Next
Set myRegExp = CreateObject("VBScript.RegExp")
myRegExp.Global = True
myRegExp.IgnoreCase = Ture
myRegExp.Pattern = "\d{4}-\d{1,2}-\d{1,2}-\d{1,2}.xls"
S = Dir(ThisWorkbook.Path & "\*.xls")
N = -1
Do While S <> ""
If UCase(S) Like "*#-*#-*#-[0-9][0-9]*.XLS" Then
N = N + 1
ReDim Preserve sz(N)
sz(N) = S
If UCase(S) Like "??[0-9]*" Then
ReDim Preserve SZ2(N)
SZ2(N) = Mid(S, 3, 1) '修改这句
End If
End If
S = Dir
Loop
Set matchs = myRegExp.Execute(Join(sz, ","))
If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out
ReDim sz1(2, 0)
For i = 0 To matchs.Count - 1
ReDim Preserve sz1(2, i)
sz1(0, i) = matchs.Item(i)
sz1(1, i) = Left(Replace(matchs.Item(i), ".xls", ""), Len(Replace(matchs.Item(i), ".xls", "")) - 3) '日期
sz1(2, i) = Right(Replace(matchs.Item(i), ".xls", ""), 2) '序号
' sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4) '序号
Next i
Application.ScreenUpdating = False
Sheet3.Activate
With Sheet3
.Columns("A:d").ClearContents
.[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)
.[d1].Resize(UBound(SZ2) + 1) = Application.Transpose(SZ2)
.[a1].CurrentRegion.Sort Key1:=Range("d1"), Order1:=xlAscending, Key2:=Range("b1"), Order2:=xlAscending, key3:=Range("c1"), _
order3:=xlAscending, Header:=xlGuess
sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
SZ2 = Application.Transpose(.Range("d1:d" & .[d1].CurrentRegion.Rows.Count))
.Columns("A:d").ClearContents
End With
For i = 1 To UBound(sz1)
For ii = i - 1 To UBound(sz)
If sz(ii) Like "??" & SZ2(i) & "*" & sz1(i) Then
temp = sz(i - 1)
sz(i - 1) = sz(ii)
sz(ii) = temp
Exit For
End If
Next ii
Next i
'数组sz已经排好了序
Sheet1.Activate
Columns("A:I").ClearContents
For i = 0 To UBound(sz)
With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
For ii = 1 To .Sheets(1).Range("A65536").End(3).Row
If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
W = 10
Else
W = 2
End If
If .Sheets(1).Range("H" & ii) = "备注" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W)
Next ii
.Close False
End With
Next i
out:
Application.ScreenUpdating = True
End Sub
Sub aaa()
"Dim sz(), sz1, SZ2(), myRegExp As Object "
On Error Resume Next '跳过错误继续执行程序
" Set myRegExp = CreateObject(""VBScript.RegExp"") ’创建一个正则表达式对象"
myRegExp.Global = True '设置正则搜索为全局搜索
myRegExp.IgnoreCase = Ture '设置正则搜索为忽略大小写
" myRegExp.Pattern = ""\d{4}-\d{1,2}-\d{1,2}-\d{1,2}.xls"" ’正则的搜索匹配模型为：4个数字，一个 - 号，1到2个数字一个 -号，1到2个数字，一个 - 号，1到2个数字，一个.号，xls"
" S = Dir(ThisWorkbook.Path & ""\*.xls"") '把dir得到的代码文件 所在的文件夹下的 xls文件名赋值给S."
N = -1 '给变量N赋值为-1
0
" Do While S <> """" ’当满足S<>""""这个条件时，执行DO循环。"
" If UCase(S) Like ""*#-*#-*#-[0-9][0-9]*.XLS"" Then ' 如果 这个xls文件名忽略大小写后符合：任何字符加一个数字加一个 - 号，加任何字符加一个数字加一个 - 号，任何字符加一个数字加一个 - 号，加两个数字，后面用或者没有任意字符.xls 这样的样式就执行下面的代码。"
N = N + 1 '计数开始，第一个N值为：-1+1=0
ReDim Preserve sz(N) ’ 保留数组sz原有值的情况下，重新字义数据sz的最后一维的个数，以便写入下一个xls文件名
sz(N) = S '把符合上面条件的xls文件名装入数组的第N个位置。
" If UCase(S) Like ""??[0-9]*"" Then '如果这个xls文件名忽略大小写后符合： 第三个字符为数字的文件。就执行下面的代码。"
ReDim Preserve SZ2(N) '在保留数组SZ2的原有元素的基础上重新扩大数组的第二维的维数为N.
" SZ2(N) = Mid(S, 3, 1) '取出文件名中的第三个字符（即第三个数字)存放在SZ2的第N个位置。"
End If ’结束IF判断
End If ’结束IF判断
S = Dir '重新取得下一个XLS文件名赋值给S。以便于DO循环进行取值。
Loop ’ DO循环线束
" Set matchs = myRegExp.Execute(Join(sz, "","")) '把数组sz中的xls文件名用，号连接起来为一个字符串。通过正则表达式的搜索，把所有符合patten模型的字符串全都取出来赋值给变量：matchs"
" If matchs.Count = 0 Then MsgBox ""没有数据文件！"", , ""提示"": GoTo out '如果没有符合pattern模式的话，matchs中的元素为0，那么弹出对话框提示“没有数据文件”，然后跳转到标签out下面的代码处执行。"
" ReDim sz1(2, 0) '重新定义数组sz1，这个二维数组的行标为0到2，列数为0到0即一列数据。"
For i = 0 To matchs.Count - 1 '开始循环正则搜索到的元素的集合
" ReDim Preserve sz1(2, i) '保留数组sz1中原来的值，扩充数组的第二维0到第i列。即正则搜索到几个元素则在数组中放几列"
" sz1(0, i) = matchs.Item(i) '把matchs中第i个符合pattern的元素存放到数组sz1中的第一行,第i个位置。"
" sz1(1, i) = Left(Replace(matchs.Item(i), "".xls"", """"), Len(Replace(matchs.Item(i), "".xls"", """")) - 3) '把取得的xls文件名中的.xls去除后，再去除这个文件名右边3个字符后的字符串存放到sz1第二行，第i列。"
" sz1(2, i) = Right(Replace(matchs.Item(i), "".xls"", """"), 2) '把正则取得的第i个文件名去除.xls后，取出最右边2个字符的字符串存入到sz1的第三行第i列"
Next i '再继续取出下一个matchs中的文件名
Application.ScreenUpdating = False '关闭屏幕刷新
Sheet3.Activate '激活第三个创建的工作表。
With Sheet3 '提示下面要进行操作的对象为sheet3
" .Columns(""A:d"").ClearContents '清除sheet3的A列到D列，只清除内容"
" .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1) 'sheet3的以A1单元格为顶点的sz1的列数为行数，3列为宽度的区域中写入转置后的sz1的元素。"
.[d1].Resize(UBound(SZ2) + 1) = Application.Transpose(SZ2) '在sheet3的以D1为顶点，行数为SZ2行数为行数，宽度为一列的区域中写入SZ2的元素。
" .[a1].CurrentRegion.Sort Key1:=Range(""d1""), Order1:=xlAscending, Key2:=Range(""b1""), Order2:=xlAscending, key3:=Range(""c1""), _ '对A1所在的连续区域进行排序：排序的第一关键字为D列数据，第二关键字为B列数据，进行升序排列，无标题行。"
" order3:=xlAscending, Header:=xlGuess"
" sz1 = Application.Transpose(.Range(""A1:A"" & .[a1].CurrentRegion.Rows.Count)) '再把排好序的A列数据存入数组sz1中"
" SZ2 = Application.Transpose(.Range(""d1:d"" & .[d1].CurrentRegion.Rows.Count)) '把排好序的D列数据存入数组SZ2中。"
" .Columns(""A:d"").ClearContents '再清除A到D列的所有内容。"
End With '对sheet3的操作完成。
For i = 1 To UBound(sz1) '对sz1中的数据进行循环
For ii = i - 1 To UBound(sz) '对sz中的数据进行循环
" If sz(ii) Like ""??"" & SZ2(i) & ""*"" & sz1(i) Then '如果sz中的第ii个元素含有:任意两个字符连接SZ2中第i个元素再连接任意字符（也可能没有任何字符)，再连接sz1中的第i个元素 这样的模式，那么执行下面的代码。"
temp = sz(i - 1) '把sz中的第i-1个元素暂时存入临时变量temp中
sz(i - 1) = sz(ii) '给sz中的第i-1个位置存放入sz中的第ii个元素。
sz(ii) = temp '再把temp中暂时存放的值放入到sz的第ii个位置
Exit For '退出循环
End If '线束if判断
Next ii '循环下一个ii
Next i '循环下一个i
Sheet1.Activate '激活第一个创建的工作表。
" Columns(""A:I"").ClearContents '清除sheet1的A列到I列的内容，只清除内容"
For i = 0 To UBound(sz) '从1开始到sz的第一维的最大下标之间进行循环
" With Workbooks.Open(ThisWorkbook.Path & ""\"" & sz(i)) '提示以新打开的工作簿（代码所在的文件夹下的文件名为sz中第i个值的文件)作为下面操作的对象"
" For ii = 1 To .Sheets(1).Range(""A65536"").End(3).Row '从1开始到新打开的文件的排在第一个的工作表的A列最后一个有数据的单元格的行号之间进行循环。"
" If ThisWorkbook.Sheets(1).Range(""A65536"").End(3).Row = 1 Then '如果代码所在的工作簿的排在第一个的工作表的A列为空，或者只有A1中有数据，那么执行下面的代码"
W = 10 '给变量W赋值为10
Else '否则
W = 2 '给W赋值为2
End If '线束if判断
" If .Sheets(1).Range(""H"" & ii) = ""备注"" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range(""A65536"").End(3)(W) '如果新打开的工作簿的排列在第一个工作表的H列的第ii行的单元格的内容是备注，那么复制这一行，粘贴到代码所在的工作簿第一个工作表的以A列最后一个有数据的单元格向下数W行的单元格为顶点的单元格区域。"
Next ii '循环下一个ii
.Close False '关闭新打开的工作簿，不保存对本工作簿的修改
End With '对此工作簿的操作结束
Next i '循环下一个i
out: '标注标签
Application.ScreenUpdating = True '打开屏幕刷新
End Sub
|
|
IP卡
狗仔卡
发表于 2014-4-8 20:09
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
抢沙发
千斤顶
显身卡
楼主
