帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-8-2 00:16 | 只看該作者

[發問] 多張工作表資料整合於總表

想將SUMMARY以外的每一張WORKSHEET內的B4的每一個編號, 在SUMMARY的A2起覆制30次, 下列寫的太不足了, 可以協助嗎? 爬文很久也想不通:'(

Sub SummurizeSheets()
Dim ws As Worksheet
Dim myrange As Range

Application.ScreenUpdating = False
Sheets("Summary").Activate

For Each ws In Worksheets
      If ws.Name <> "Summary" Then
         Sheets("summary").myrange("A2:A30").End(xlUp) = ws.Range("B4:B3").Copy
         ActiveSheet.Paste Range("A65536").End(xlUp).Offset(1, 0)
      End If
Next ws
End Sub

VBA 資料轉置4.rar (25.38 KB)

樓主熱帖

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

2^#

發表於 2015-8-2 01:33 | 只看該作者

回復 1# missbb

試試看
      For Each ws In Worksheets
      If ws.Name <> "Summary" Then
         ws.Range("B4").Copy
         aa = Sheets("summary").Range("A65536").End(xlUp).Row + 1
         Sheets("summary").Paste Sheets("summary").Range("A" & aa, "A" & aa + 29)
      End If
Next ws

TOP

missbb

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

3^#

發表於 2015-8-2 11:51 | 只看該作者

回復 2# lpk187

新問題, 我想每次行駛COPY時, 要先將SUMMARY的內容CLEAR, 加入下列, 但出現424 的ERROR, 是甚府問題呢?:dizzy:
Sub Clear_Contents_Range()
Workbook.Sheets("summary").Cells.ClearContents
End Sub

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2015-8-2 14:55 | 只看該作者

回復 5# missbb

Workbook.Sheets("summary").Cells.ClearContents

此處需要物件 (錯誤 424)
修改看看

Workbooks("活頁簿名稱").Sheets("summary").Cells.ClearContents

複製代碼

可以不用Copy

For Each ws In Worksheets
If ws.Name <> "Summary" Then
Sheets("summary").Range("A65536").End(xlUp).Offset(1).Resize(30)= ws.Range("B4")
End If
Next

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

missbb

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

5^#

發表於 2015-8-2 15:14 | 只看該作者

回復 7# GBKEE

CLEAR CONTENT成功了, 但因WORKBOOK內有超過1張SHEET, 每張SHEET均由B4起有不同長度的數值, 現在是取了每工作表的B4數值, 我改了下列, 卻又只取了每工作表的最後一列數值, 請指導?

Sheets("summary").Range("A65536").End(xlUp).Offset(1).Resize(30) =

VBA.rar (26.49 KB)

TOP

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

6^#

發表於 2015-8-2 16:18 | 只看該作者

回復 8# missbb

當複製的來源只有一個儲存格，內存只會把這個儲存格的內容當成一個字串，所以它會把這個字串分成N個字串分別複製到目的的儲存格，
但若有超過一個以上的來源儲存格，則會成為陣列，所以必須成為
目的儲存格的範圍數量(Count)=來源儲存格的範圍數量(Count)

Sub move()
For Each ws In Worksheets
ll = ws.Name
If ws.Name <> "summary" Then
範圍數量 = ws.Range("B4", ws.Range("B65536").End(xlUp).Address).Count
範圍陣列內容 = ws.Range("B4", ws.Range("B65536").End(xlUp).Address)'使其成為陣列
Sheets("summary").Range("A65536").End(xlUp).Offset(1).Resize(範圍數量) = 範圍陣列內容
End If
Next
End Sub

複製代碼

TOP

missbb

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

7^#

發表於 2015-8-2 18:03 | 只看該作者

回復 9# lpk187

對不起, 按你的方法只能將每個工作表的B4內容顯示1次.

如改為RESIZE 30, 則出配#NA

問題在那呢?:dizzy:

TOP

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

8^#

發表於 2015-8-2 18:39 | 只看該作者

回復 10# missbb

我在9樓就有解釋給你了，單一有單一的做法，範圍有範圍的做法，單一不一定能套用在範圍
Sub move()
For Each ws In Worksheets
ll = ws.Name
      If ws.Name <> "summary" Then
         範圍數量 = ws.Range("B4", ws.Range("B65536").End(xlUp).Address).Count
         範圍陣列內容 = ws.Range("B4", ws.Range("B65536").End(xlUp).Address) '使其成為陣列
         For Each Rng In 範圍陣列內容
            Sheets("summary").Range("A65536").End(xlUp).Offset(1).Resize(30) = Rng
         Next
      End If
Next
End Sub

TOP

missbb

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

9^#

發表於 2015-8-2 19:42 | 只看該作者

回復 11# lpk187

多謝你不辭勞苦地給我解答, 雖然學習中, 會繼續努力:L

TOP

missbb

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

10^#

發表於 2015-8-6 14:08 | 只看該作者

回復 5# GBKEE

早前給我的指導, 現求教如需每個PDF均發出一個電郵, 下列的程式要如何更改呢? 求賜教!

Sub ex()
Set d = CreateObject("Scripting.Dictionary")
With Worksheets("attendance report")
For Each a In .Range(.[E4], .[E4].End(xlDown))
  d(a.Value) = ""       '取得所有不重複分店
Next
F = InputBox("Enter your month")

For Each ky In d.keys
   .Range("B4").AutoFilter Field:=4, Criteria1:=ky
   If Dir("C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf") <> "" Then Kill "C:\Users\mariasfy\Desktop\" & ky & "_" & F & "201507.pdf" '同名檔案刪除
   .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
      "C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, OpenAfterPublish:=False  '另存成PDF檔案

Next

Dim Mail_Object, Mail_Single As Variant
Email_Subject = "門市出勤報告"
Email_Cc = ""
Email_Bcc = ""
Email_Body = "門市出勤報告, 請回覆"

Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(o)

With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.CC = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.Attachments.Add ("C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf")
.Display
'.send
End With

If .FilterMode = True Then .ShowAllData '顯示所有資料

End With

End Sub

TOP