| 网站首页 | 业界新闻 | 小组 | 交易 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
 Reworld，下班在家制作游戏，1500万奖金等你拿 以码会友 以友辅仁

已结贴   问题点数：10  回复次数：10

Sub 批量创建新表()

Application.ScreenUpdating = False
Dim FileName As String
Dim Workbook As Workbook
Dim r As Integer
FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
Set Workbook = Application.Workbooks.Open(ThisWorkbook.Path & "\" & FileName)
With Workbook
.Sheets(1).UsedRange.Copy
r = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 2
ThisWorkbook.Sheets(1).Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows(3).Resize(r + 1, 1).EntireRow.Select
Selection.RowHeight = 20
.Close False
End With
Range("B3").Resize(r - 2, 5).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
ThisWorkbook.SaveAs FileName:="C:\Users\HGH\Desktop & " \ " & FileName", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
FileName = Dir
Loop
Application.ScreenUpdating = True

End Sub

ThisWorkbook.SaveAs FileName:="C:\Users\HGH\Desktop & " \ " & FileName", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

[此贴子已经被作者于2017-12-14 21:41编辑过]

得分:10

【这个实现的功能是把没打开的保存到当前打开的表中，没做保存】

Sub 批量创建新表()
Application.ScreenUpdating = False
Dim FileName As String
Dim Workbook As Workbook
Dim rg As Range
Dim r As Integer
FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
Set Workbook = Application.Workbooks.Open(ThisWorkbook.Path & "\" & FileName)
With Workbook
.Sheets(1).UsedRange.Copy
r = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 2
temp = "B" & Trim(Str(r))'新增的控制下一文件在最后面复制
ThisWorkbook.Sheets(1).Range(temp).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Close False
End With
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2017-12-15 23:36编辑过]

得分:0

得分:0

得分:0

得分:0

得分:0

Sub 批量创建新表()
Application.ScreenUpdating = False
Dim FileName As String
Dim Workbook As Workbook
Dim rg As Range
Dim r As Integer
Dim n As Integer
n = 1'文件计数用
FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
Set Workbook = Application.Workbooks.Open(ThisWorkbook.Path & "\" & FileName)
With Workbook
.Sheets(1).UsedRange.Copy
r = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 2
ThisWorkbook.Sheets(1).Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Close False
End With

N_PATH = ThisWorkbook.Path '定义保存路径，可自己定义保存位置
N_NAME = N_PATH & "\导出文件名称" & Trim(Str(n)) & ".xls" '定义保存文件路径及文件名
ActiveWorkbook.SaveAs N_NAME
n = n + 1
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
得分:0

得分:0

得分:0

• 11
• 1/2页
• 1
• 2