Excel VBA Sheet分頁合併問題請教

Hi 各位大大好，

小弟在VBA Sheet分頁合併時怎麼改都有問題 = =:，想請教如何解決，謝謝
原因:想把分頁內搜尋到的項目整個欄位全部複制合併至新Sheet
結果: 1、分頁最後一列會被後面的分頁蓋過去 2、當欄位未填滿時，複制的位置會跑掉

[點擊下載]

VBA code :
Private Sub CommandButton1_Click()

Dim ws As Worksheet
Dim sh As Worksheet, i%
Dim searchRange As Range
Dim firstAddress As String
Dim foundCell As Range
Dim arr()

arr = Array("Item", "Phone", "Computer")

'錯誤繼續進行
On Error Resume Next

'關閉螢幕刷新
Application.ScreenUpdating = False
'停用警告提示
Application.DisplayAlerts = False

Worksheets("Merge").Delete
Set ws = Worksheets.Add(before:=Sheets(1))

'命名工作表
ws.name = "Merge"

For Each sh In Sheets:

For i = 0 To UBound(arr)

If sh.name <> "Merge" Then

Set searchRange = sh.Cells

Set foundCell = searchRange.Find(What:=arr(i), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If Not foundCell Is Nothing Then

firstAddress = foundCell.Address

Do
' 對找到的每一個匹配的單元格進行操作
'MsgBox "Found ' " & foundCell.Value & " ' in " & sh.name & " => " & foundCell.Address

If sh_list <> sh.name Then

x = ActiveSheet.UsedRange.Rows.Count + 2
'x = x + 1
Else
x = ActiveSheet.UsedRange.Rows.Count + 2 - m

End If

'MsgBox ActiveSheet.UsedRange.Rows.Count

ws.Cells(x, 1) = sh.name

sh_list = ws.Cells(x, 1)

Worksheets(sh.name).Activate
sh.Range(foundCell.Offset(0, 0), foundCell.End(xlDown)).Select
Selection.Copy
ws.Select

FieldNumber = Application.Match(arr(i), arr, 0) + 1

Cells(x, FieldNumber).Select
Selection.PasteSpecial xlPasteValues

m = Cells(Rows.Count, FieldNumber).End(xlUp).Row - x

' 繼續尋找下一個匹配的單元格
Set foundCell = searchRange.FindNext(foundCell)

' 繼續迴圈直到回到第一個匹配位置
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
Else
MsgBox "Not found in sheet ' " & sh.name & " '"
End If

Sheets(1).Select

End If

Next i
Next

'開啟警告提示
Application.DisplayAlerts = True
'開啟螢幕刷新
Application.ScreenUpdating = True
'取消複制模式
Application.CutCopyMode = False

MsgBox "Merge Ok"

End Sub

2024-12-12 18:14 #1

文章關鍵字

Excel VBA Sheet 分頁合併問題

snare

3011分

2樓

snare

個人積分：3011分

文章編號：90793122

新版excel 工作表合併是內建功能，不需要用到VBA
如果是用舊版的，根據您的資料格式，vba簡易範例如下

Sub test()

    Dim ws As Worksheet, sh As Worksheet, R As Long, MergeR As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Worksheets("Merge").Delete
    On Error GoTo 0
    
    Set ws = Worksheets.Add(before:=Sheets(1))
    ws.Name = "Merge"
    
    For Each sh In Sheets
        If sh.Name <> "Merge" Then
            R = LastRow(sh)
            If R = 0 Then
                'MsgBox "No Data:" & sh.Name
            Else
                MergeR = LastRow(ws) + 2
                ws.Range("b" & MergeR).Resize(R, 3).Value = sh.Range("a1").Resize(R, 3).Value
                ws.Range("a" & MergeR) = sh.Name
            End If
        End If
    Next
    
    ws.Cells(1, 1) = "合併結果"
    Sheets(1).Select
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    

End Sub

Function LastRow(sh As Worksheet) As Long
    
    On Error Resume Next
    LastRow = sh.Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
    On Error GoTo 0
    
End Function

emyb

0分

樓主

emyb

個人積分：0分

文章編號：90794404

感謝snare高手的回覆
程式相當精簡，我還需要研究一下,謝謝
如果想改成只複制搜尋到的欄位用陣列的方式，如何修改呢?

Function LastRow(sh As Worksheet) As Long
arr = Array("Item", "Phone", "Computer")
On Error Resume Next
For i = 0 To UBound(arr)
LastRow = sh.Cells.Find(arr(i), ActiveCell, xlFormulas, , xlRows, xlPrevious).Row
Next i
On Error GoTo 0
End Function