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

missbb

想將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

lpk187

回復 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

missbb

回復 2# lpk187

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

GBKEE

回復 5# missbb

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

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

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

複製代碼

可以不用Copy

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

複製代碼

missbb

回復 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)

下載次數: 3

2015-8-2 15:13

lpk187

回復 8# missbb


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

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

複製代碼

missbb

回復 9# lpk187

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

下載 (5.4 KB)

2015-8-2 18:03

如改為RESIZE 30, 則出配#NA

下載 (6.57 KB)

2015-8-2 18:03

問題在那呢?:dizzy:

lpk187

回復 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

missbb

回復 11# lpk187

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

missbb

回復 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