vba合并全部sheet
Sub ADO联合查询（）
Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&
Set cnn = CreateObject(＂ADODB.Connection＂)
[a:b].ClearContents
MyPath = ThisWorkbook.Path & ＂\＂
MyFile = Dir(MyPath & ＂*.xls＂)
Do While MyFile ＂＂
If MyFile ThisWorkbook.Name Then
n = n + 1
If n = 1 Then cnn.Open ＂Provider=Microsoft.Jet.OLEDB.4.0;Extended;Data Source=＂ & MyPath & MyFile
m = m + 1
If m >49 Then
Range(＂a＂ & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
m = 1
SQL = ＂＂
End If
If Len(SQL) Then SQL = SQL & ＂ union all ＂
SQL = SQL & ＂select f1,'＂ & Replace(MyFile, ＂.xls＂, ＂＂) & ＂' from [Excel 8.0;hdr=no;Database=＂ & MyPath & MyFile & ＂].[Sheet1$A2:A]＂
End If
MyFile = Dir()
Loop
If Len(SQL) Then Range(＂a＂ & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
cnn.Close
Set cnn = Nothing
End Sub
用vba插入合并填充单元格
Private Sub CommandButton1_Click()
'最后一行r，上面插入一行，横向合并单元格n格，填充数据s
Dim n, s, col, r, tmp
'----设定----
n = 2 '横向合并单元格n格
s = ＂XXXXXX＂ '填充数据s
col = ＂A＂ '以col列为操作的最左列
'----执行----
With ActiveSheet
r = .Cells(65536, col).End(xlUp).Row
.Rows(r).Insert xlShiftDown '插入行
With .Cells(r, col).Resize(1, n)
.Merge '合并单元格
.Value = s '填充数据
End With
End With
End Sub
