關於excel 工作表合併的問題

excel vbs 合併

rex0220 2023-05-17 17:28:47 ‧ 811 瀏覽

分享至

在模組新增以下程式碼然後執行，文字合併都正確，但圖片就無法合併直接消失，如果要連圖片一起合併的話需要怎麼修改呢?
麻煩大家回答了，感謝。

Sub 合并当前工作簿下的所有工作表()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set st = Worksheets.Add(before:=Sheets(1))
st.Name = "合并"
For Each shet In Sheets:
If shet.Name <> "合并" Then
i = st.Range("A" & Rows.Count).End(xlUp).Row + 1
shet.UsedRange.Copy
st.Cells(i, 1).PasteSpecial Paste:=xlPasteAll
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "已完成"
End Sub

登入發表討論

熱門推薦

{{ item.channelVendor }} | {{ item.webinarstarted }} |

直播中

1 個回答

GGU.IN

iT邦新手 4 級 ‧ 2023-05-18 10:24:15

最佳解答

Sub 合併所有工作表()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim st As Worksheet
    Set st = Worksheets.Add(before:=Sheets(1))
    st.Name = "合併"
    For Each shet In Sheets
        If shet.Name <> "合併" Then
            Dim i As Long
            i = st.Range("A" & Rows.Count).End(xlUp).Row + 1
            shet.UsedRange.Copy
            st.Cells(i, 1).PasteSpecial Paste:=xlPasteAll
            Dim pic As Picture
            For Each pic In shet.Pictures
                pic.Copy
                st.Pictures.Paste
                With st.Pictures(st.Pictures.Count)
                    .Top = st.Cells(i, 1).Top
                    .Left = st.Cells(i, 1).Left
                End With
            Next pic
        End If
    Next shet
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成"
End Sub

回應 6
分享
檢舉

看更多先前的回應...收起先前的回應...

rex0220 iT邦新手 4 級 ‧ 2023-05-18 10:43:23 檢舉

非常感謝協助，但是合併後圖片雖然有到合併的資料表，可是卻重疊一起，沒有對應到欄位裡面，這是該怎麼處理呢

GGU.IN iT邦新手 4 級 ‧ 2023-05-18 11:10:05 檢舉

這個合併後要調整成文繞圖我不會弄,只能改成相對位置

rex0220 iT邦新手 4 級 ‧ 2023-05-18 11:16:27 檢舉

我了解了，圖片本來就沒辦法綁定在欗位裡，應該是這關係吧

GGU.IN iT邦新手 4 級 ‧ 2023-05-18 11:19:30 檢舉

假設
工作表1:2行資料
工作表2:5行資料
工作表3:7行資料
因為是縱向合併所以你第一張圖片只能放在右側,並且長寬
不能超過2行,以此類推

GGU.IN iT邦新手 4 級 ‧ 2023-05-18 11:21:01 檢舉

Sub 合併所有工作表()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim st As Worksheet
    Set st = Worksheets.Add(before:=Sheets(1))
    st.Name = "合併"
    For Each shet In Sheets
        If shet.Name <> "合併" Then
            Dim i As Long
            i = st.Range("A" & Rows.Count).End(xlUp).Row + 1
            shet.UsedRange.Copy
            st.Cells(i, 1).PasteSpecial Paste:=xlPasteAll
            Dim pic As Picture
            For Each pic In shet.Pictures
                pic.Copy
                st.Pictures.Paste
                With st.Pictures(st.Pictures.Count)
                    .Top = st.Cells(i, 1).Top + pic.Top
                    .Left = st.Cells(i, 1).Left + pic.Left
                End With
            Next pic
        End If
    Next shet
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成"
End Sub