| EXCEL 合併分頁
Sub Macro1()
Dim sh As Worksheet, A As Range, Rng As Range, i%, r&
Application.DisplayAlerts = True
r = 1 '初始化r值因為要貼到第1列開始
Set sht = Sheets.Add(before:=Sheets(1)) '新增空白工作表準備接收資料並設成變數sht
For Each sh In Sheets '對每個工作表做循環
If sh.Name <> sht.Name Then '若跟新增表名不同就做以下動作否則就到下一工作表
Set A = sh.UsedRange '將工作表所使用的儲存格設為變數A
A.Copy sht.Cells(r, 1) '將A複製到新表
r = r + A.Rows.Count '讓r值增加所用列數為下一表資料目的起始列位
'sh.Delete '刪除已複製工作表
End If
Next
With sht
On Error Resume Next
Set Rng = Range(.[A1], .Cells(r, 1)).SpecialCells(xlCellTypeBlanks) '已複製完成的表格在A欄的所有空格設成變數Rng
For Each A In Rng '在每個空格做循環
For i = 1 To 18 '因為資料有8欄從A欄向右尋找
If A.Offset(, i) <> "" Then A.Offset(-1, i) = A.Offset(-1, i) & A.Offset(, i) '到有資料處就跟上一列儲存格內容合併
Next
Next
Rng.EntireRow.Delete '把空白列刪除
End With
Application.DisplayAlerts = True
End Sub
EXCEL 多個檔案合併成一個檔中之分頁
Sub Macro1()
Dim sh As Worksheet, NewBk As Workbook
Dim Path$, Word$, ShName$, File$, Tmp$
Path = [b1]
Word = [b2]
ShName = [b3]
File = Dir(Path & "*.xls") '搜尋檔案
If File = "" Then GoTo Ex
first = File
Set NewBk = Workbooks.Add
Do
Tmp = Left(File, InStrRev(File, ".") - 1) '取檔案名
If InStr(Tmp, Word) Then
Workbooks.Open Path & File
On Error Resume Next
Set sh = ActiveWorkbook.Worksheets(ShName)
On Error GoTo 0
If Not sh Is Nothing Then
i = i + 1
sh.Copy after:=NewBk.Worksheets(NewBk.Sheets.Count) '複製檔案
NewBk.Worksheets(NewBk.Sheets.Count).Name = Tmp & Word '改sheet名
sh.Parent.Close False
End If
End If
File = Dir
Loop Until first = File Or File = ""
If i Then '判斷是否有符合的資料
MsgBox i & "筆符合檔案"
Else
NewBk.Close False
Ex: MsgBox "無符合檔案"
End If
End Sub |
住戶編號:41158
檢舉原因
心情: 
