Board logo

標題: [發問] 多張工作表資料整合於總表 [打印本頁]
作者: missbb    時間: 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
作者: lpk187    時間: 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
作者: missbb    時間: 2015-8-2 11:51

回復 2# lpk187

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

回復 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    時間: 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) = [attach]21624[/attach]
作者: lpk187    時間: 2015-8-2 16:18

回復 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    時間: 2015-8-2 18:03

回復 9# lpk187

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

如改為RESIZE 30, 則出配#NA


[attach]21628[/attach]
問題在那呢?:dizzy:
作者: lpk187    時間: 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
作者: missbb    時間: 2015-8-2 19:42

回復 11# lpk187

多謝你不辭勞苦地給我解答, 雖然學習中, 會繼續努力:L
作者: missbb    時間: 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
作者: GBKEE    時間: 2015-8-7 14:52

回復 11# missbb

試試看
  1. Option Explicit
  2. Sub ex()
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     With Worksheets("attendance report")
  5.         For Each a In .Range(.[E4], .[E4].End(xlDown))
  6.             d(a.Value) = ""         '取得所有不重複分店
  7.         Next
  8.         F = InputBox("Enter your month")
  9.         For Each ky In d.keys
  10.             .Range("B4").AutoFilter Field:=4, Criteria1:=ky
  11.             If Dir("C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf") <> "" Then Kill "C:\Users\mariasfy\Desktop\" & ky & "_" & F & "201507.pdf" '同名檔案刪除
  12.             .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
  13.             "C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
  14.             IgnorePrintAreas:=False, OpenAfterPublish:=False  '另存成PDF檔案
  15.             '************************************************************
  16.             SendMail "C:\Users\mariasfy\Desktop\" & ky & "_" & F & ".pdf"
  17.             '************************************************************
  18.         Next
  19.     End With
  20. End Sub
  21. Sub SendMail(xFile As String)
  22.     'VBA 功能表指令: 工具->設定引用項目 新增 -> [Microsoft CDO for Windows 2000 Library]
  23.     '可 Google   CreateObject("CDO.Message") 了解
  24.     Dim objEmail As Object
  25.     Set objEmail = CreateObject("CDO.Message")      '建立 CDO 物件
  26.     With objEmail
  27.         With .Configuration.Fields
  28.             .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
  29.             .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "msa.hinet.net"              '使用 msa.hinet.net 傳送郵件
  30.             .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
  31.             .Update
  32.         End With
  33.         .From = "寄件者@pchome.com"           '寄件者（網域必須存在）
  34.         .To = "收件者@gmail.com"
  35.         .Subject = "CreateObjectCDO.Message CDO郵件測試"    '郵件主旨
  36.         .HTMLBody = "郵件本文"   'HTML郵件內文
  37.         .AddAttachment xFile   '附檔
  38.         .Send
  39.     End With
  40. End Sub
複製代碼
作者: missbb    時間: 2015-8-8 09:07

回復 11# GBKEE

讓我試一下, 感激!:'(
作者: missbb    時間: 2015-8-8 23:23

本帖最後由 missbb 於 2015-8-8 23:29 編輯

回復 12# missbb

我可以將工作表ATTENDANCE REPORT V3:AZ3的日期轉置到工作表LEAVE SUMMAy, 但v3:AZ3如何以copy 30次對應每個員工, 因員工不員1個?

如何可以將每個員工的ATTENDANCE REPORT內的"假期/例假/備註"列內的勞或例按員工及日期配置於leave summary的d欄呢? 用函數(IF(ISERROR(INDEX('ATTENDANCE REPORT'!$1:$1048576,MATCH($A$2,'ATTENDANCE REPORT'!$M:$M,0),MATCH(DAY($C2),'ATTENDANCE REPORT'!$3:$3,0))),"",INDEX('ATTENDANCE REPORT'!$1:$1048576,MATCH($A$2,'ATTENDANCE REPORT'!$M:$M,0),MATCH(DAY($C2),'ATTENDANCE REPORT'!$3:$3,0)))是可以做到, 或如何將函數加入vba內?

未完的vba:
Sheets("attendance report").Range("v3:az3").Copy
Sheets("leave summary").Range("c2").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
   
感激![attach]21673[/attach]



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)