[已解决]批量添加序号的问题

席幕容

附件 批量添加序号.zip (227.33 KB, 下载次数: 22)

2015-3-6 10:48 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-6 11:05

请看附件。

跳转到最佳答案楼层

grf1973

1. Sub 批量写入()
   
2.     Application.ScreenUpdating = False
   
3.     Dim filename, wb As Workbook, Sht As Worksheet
   
4.     filename = Dir(ThisWorkbook.Path & "\*.xlsx")
   
5.     Do While filename <> ""
   
6.         If filename <> ThisWorkbook.Name Then
   
7.             fn = ThisWorkbook.Path & "" & filename
   
8.             Set wb = Workbooks.Open(fn)
   
9.             Set Sht = wb.Worksheets(1)
   
10.             arr = Sht.[a1].CurrentRegion: r = UBound(arr)
    
11.             ReDim brr(1 To r, 1 To 1)
    
12.             For i = 1 To r: brr(i, 1) = i: Next
    
13.             Sht.Cells(1, UBound(arr, 2) + 1).Resize(r, 1) = brr
    
14.             wb.Close True
    
15.         End If
    
16.         filename = Dir
    
17.     Loop
    
18.     Set Sht = Nothing
    
19.     Application.ScreenUpdating = True
    
20. End Sub
    

复制代码

grf1973

请看附件。

dsmch

1. Dim n%
   
2. Sub Macro1()
   
3. n = n + 1
   
4. If n > 1 Then Exit Sub
   
5. Dim mypath$$, wj$$, arr, brr, i&
   
6. mypath = ThisWorkbook.Path & ""
   
7. Application.ScreenUpdating = False
   
8. Application.DisplayAlerts = False
   
9. wj = Dir(mypath & "*.xls*")
   
10. Do While wj <> ""
    
11.     If wj <> ThisWorkbook.Name Then
    
12.         With Workbooks.Open(mypath & wj)
    
13.             arr = Range("a1").CurrentRegion
    
14.             ReDim brr(1 To UBound(arr), 1 To 1)
    
15.             For i = 1 To UBound(arr)
    
16.                 brr(i, 1) = i
    
17.             Next
    
18.             Cells(1, UBound(arr, 2) + 1).Resize(i - 1) = brr
    
19.             .Close 1
    
20.         End With
    
21.     End If
    
22.     wj = Dir
    
23. Loop
    
24. Application.DisplayAlerts = True
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码