如何用VBA合并同文件夹中的格式相同的工作表。
发布网友
共4个回答
热心网友
我经常用这个修改合并
Sub G22表10日()
Dim SQL0$, strTbl$, i%, thisbookname$, thisheetname$, sName$, cn, sh, rowend&, rng$
Dim Filename As Variant
Dim RefEdit1, RefEdit2, RefEdit3, RefEdit4 As String
Filename = Application.GetOpenFilename("Microsoft Office Excel Files (*.xls), *.xls", , "请选取文件", , True)
If Not IsArray(Filename) Then Exit Sub
thisbookname = ActiveWorkbook.Name
thisheetname = ActiveSheet.Name
'多文件求和汇总
Application.DisplayAlerts = False
Application.ScreenUpdating = False
RefEdit1 = "$c$9:$c$11" '需合并的数据区域
RefEdit2 = "$c$14:$c$14"
RefEdit3 = "$c$18:$c$19"
RefEdit4 = "$c$21:$c$23"
For i = 1 To UBound(Filename)
sName = Dir(Filename(i))
Workbooks.Open Filename(i), UpdateLinks:=0
Workbooks(sName).Worksheets(thisheetname).Activate
rng = Range(RefEdit1).Address
Range(rng).Copy
Workbooks(thisbookname).Activate
Range(rng).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
Workbooks(sName).Worksheets(thisheetname).Activate
rng = Range(RefEdit2).Address
Workbooks(sName).Worksheets(thisheetname).Activate
Range(rng).Copy
Workbooks(thisbookname).Activate
Range(rng).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
Workbooks(sName).Worksheets(thisheetname).Activate
rng = Range(RefEdit3).Address
Range(rng).Copy
Workbooks(thisbookname).Activate
Range(rng).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
Workbooks(sName).Worksheets(thisheetname).Activate
rng = Range(RefEdit4).Address
Range(rng).Copy
Workbooks(thisbookname).Activate
Range(rng).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
Workbooks(sName).Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub追问谢谢，你好像没有看清我的要求。
你的这段代码，我试了下结果是空白，最后选中C21：C23这位个单元格，我将区域改了后出现的也只是这片区域被选中，而不是将原表数据搬过来
追答Sub CombineWorkbooks()
Dim FilesToOpen, wb
Dim x As Integer, str$
On Error GoTo errhandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename(Filefilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "没有选中文件"
GoTo exithandler
End If
x = 1
While x <= UBound(FilesToOpen)
D最后行 = [B65536].End(xlUp).Row + 1
Set wb = Workbooks.Open(FilesToOpen(x))
最后行 = wb.Sheets("表一").[B65536].End(xlUp).Row
wb.Sheets("表一").Rows("3:" & 最后行).Copy Destination:=ThisWorkbook.Sheets("表一").Rows(D最后行)
'Wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
str = wb.Name
str = Left(str, Len(str) - 4)
x = x + 1
wb.Close False ' 不保存就关闭这个打开的工作簿
' Range(Cells(D最后行, 1), Cells(D最后行 + 最后行 - 2, 1)) = str '文件名
Wend
exithandler:
Application.ScreenUpdating = True
Exit Sub
errhandler:
MsgBox Err.Description
Resume exithandler
End Sub
热心网友
看别人的代码是最难的，所以我提供一下另一种思路。
1.归类：先用代码查找格式相同的文件，将这些文件放到别的文件夹下。
2.合并：按顺序打开每一个文件，复制指定区域，粘贴到新的文件里。
如果你觉得我的思路可以，而自己搞不定代码的话，可以Q我：369866705
热心网友
Sub 删除不连续的空白行()
Dim i, m, n, a, b, c,
m = 0
n = 5000
b = 0
For i = 5000 To 1 Step -1
2 If Sheet1.Cells(i, 1) = "" Then
n = i
m = m + 1
ElseIf Sheet1.Cells(i, 1) <> "" Then
If m = 0 Then
GoTo 3
Else
Range(Cells(n, 1), Cells(n + m - 1, 256)).Delete
m = 0
End If
3 For c = n - 1 To 1 Step -1
If Sheet1.Cells(c, 1) <> "" Then
a = c
b = b + 1
Else
i = c
GoTo 2
End If
Next c
i = c
End If
Next i
End Sub
这个是粗略的，没有简化
热心网友
采用单行复制
j = 1
For i = 1 To Max
If Cells(i, 1).Value <> "" Then
Sheets("Sheet1").Rows([i]).Copy Sheets("Sheet1").Rows([j])
j = j + 1
End If
Next i
或选择性批量复制
Dim i%, r%
Dim rag As Range
i = 1
For Each rag In Sheets("Sheet2").Range("A1:A100") ''判断A列是否空值
If rag.Value <> "" Then
r = rag.Row
Sheets("Sheet2").Rows([r]).Copy Sheets("Sheet1").Rows([i])
i = i + 1
End If
Next
参考资料：http://zhidao.baidu.com/question/84622759.html?fr=qrl&cid=8&index=3&fr2=query
