[已解决]请求赐教！内容有更新。两个 ...

松儿

请求赐教！内容有更新。两个日期合并拆分a。.rar (11.31 KB, 下载次数: 5)

2013-1-20 16:49 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-20 17:14

请求赐教！内容有更新。两个日期合并拆分a。.rar (30.79 KB, 下载次数: 13)

2013-1-20 17:14 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

1. Sub 拆分2()
   
2.     Dim iCol&, rg As Range, a As Worksheet, wbname$
   
3.     Worksheets("sheet1").Activate
   
4.     Application.ScreenUpdating = False
   
5.     On Error Resume Next
   
6.     With Worksheets("sheet1")
   
7.         Set rg = .Range("e3")
   
8.         iCol = rg.Column
   
9.         Do While iCol <> Columns.Count
   
10.             wbname = rg.Offset(, 2).Value
    
11.             Debug.Print wbname, iCol
    
12.             Set a = Worksheets(wbname)
    
13.             If a Is Nothing Then
    
14.                 Worksheets.Add after:=Worksheets(Worksheets.Count)
    
15.                 ActiveSheet.Name = wbname
    
16.                 .Range("a:c").Copy Range("a1")
    
17.                 .Columns(rg.Column).Resize(, 5).Copy Range("d1")
    
18.             End If
    
19.             Set rg = rg.End(xlToRight)
    
20.             iCol = rg.Column
    
21.             Set a = Nothing
    
22.         Loop
    
23.     End With
    
24.     Worksheets("sheet1").Activate
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "拆分完毕"
    
27. End Sub

复制代码

hwc2ycy

请求赐教！内容有更新。两个日期合并拆分a。.rar (30.79 KB, 下载次数: 13)

2013-1-20 17:14 上传

点击文件名下载附件