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
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .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编辑过]

你这个程序是execl的vba程序，出错的是格式设置部分，我把格式部分去掉了

实现功能：把同一目录的*.xlsx复制到打开的B3开始的位置

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

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编辑过]

代码貌似还是有问题，还是不能实现将打开的工作簿内容复制粘贴到当前表，然后再另存为一个新的工作簿，.........一直循环完当前工作表路径下的所有文件

你的意思是把每一个龙凤山村X组表单独粘贴到身份证件信息统计表，之后另存。
我理解为把所有表复制到身份证件信息统计表。

如果是每一个龙凤山村X组表粘贴到身份证件信息统计表，再保存，那么保存格式是什么，粘贴到哪个sheet。
最好有示例。

另存为一个新的工作簿，在当前工作簿所在文件路径下

谢谢🙏

把原来的表重新另存，没做格式设置
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'文件计数用
    Application.DisplayAlerts = False'屏蔽提示
    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

我测试了下，代码还是有缺陷

这个是不是不容易实现啊

不是不容易实现。
想实现什么样的目标，必须描述清楚，这样才能达到目的。
另外，怎么达到自己满意，还得自己动脑。

我看你的表格，没有什么复杂数据，用不用VBA都可以。
如果是想自动化，那么vba宏处理不如，文件方式好；
如果想锻炼开发，那么多查查资料，多调试，是最好的方法。

另外我给你写的2次，1次是把当前目录到*.xlsx内容加表头都复制到身份证表；另一个是把当前目录到*.xlsx内容加表头单个复制到每个导出文件.xls。
文件边框，格式，居中，字体等，好设置，你录一下宏，就知道。