VBA合并所有工作表

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