iT邦幫忙

0

關於excel 工作表合併的問題

  • 分享至 

  • xImage

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

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 }} |
{{ formatDate(item.duration) }}
直播中

1 個回答

0
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


看更多先前的回應...收起先前的回應...
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

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

如果要大圖或放其他位置,你在自己調整成合併中間加上幾行空白行

我要發表回答

立即登入回答