[發問] 累積報表修正語法

請教各位先進~
目前有兩個SHEET
想要把每日的資料複製至日累積報表
[每日資料]

[日累積]

由於目前是把每日資料逐行帶入日累積報表中
想請問要如何修正語法才能自動讀[每日資料]有幾行
複製到[日累積]有資料的下一行

小妹目前語法

Sub TEST()
Dim a, b, c, today
Dim i As String
i = Sheets("日累積").Range("A65536").End(xlUp).Row '計算有資料最後一列之列數
j = Sheets("日檢核").Range("A65536").End(xlUp).Row
'比對日期
If Worksheets("日累積").Cells(i, 1).Value = Sheets("日檢核").Range("J2") Then MsgBox "早已存過資料！"
If Worksheets("日累積").Cells(i, 1).Value <> Sheets("日檢核").Range("J2") Then
For a = 1 To j - 1
'日期匯出
Sheets("日累積").Cells(i + a, 1).Value = Sheets("日檢核").Range("J2")
'這裡是想要修正的地方因日檢核資料有時多有時少不能寫死
Sheets("日累積").Range(Cells(i + 1, 2), Cells(i + 1, 8)) = Sheets("日檢核").Range("A2:G2").Value
Sheets("日累積").Range(Cells(i + 2, 2), Cells(i + 2, 8)) = Sheets("日檢核").Range("A3:G3").Value
Sheets("日累積").Range(Cells(i + 3, 2), Cells(i + 3, 8)) = Sheets("日檢核").Range("A4:G4").Value
Sheets("日累積").Range(Cells(i + 4, 2), Cells(i + 4, 8)) = Sheets("日檢核").Range("A5:G5").Value
Next a
MsgBox "資料匯出完成！" ' 匯出完成訊息
End If
End Sub

複製代碼

麻煩了~

活頁簿0118.zip (386.27 KB)

論壇贊助勳章

2^#

發表於 2017-2-2 16:51 | 顯示全部帖子

回復 2# justintoolbox

有成功執行喔~~
結果也是想要的
謝謝你^^

論壇贊助勳章

3^#

發表於 2017-2-23 11:49 | 顯示全部帖子

回復 4# jsc0518

試試~ 我稍稍結合了一下

Sub TEST()
Dim Rng, Dr
Dim i, j As String
Dim x As Integer
i = Sheets("日累積").Range("A65536").End(xlUp).Row '計算有資料最後一列之列數
j = Sheets("日檢核").Range("A65536").End(xlUp).Row
'比對日期
If Worksheets("日累積").Cells(i, 1).Value = Sheets("日檢核").Range("J2") Then MsgBox "早已存過資料！"
If Worksheets("日累積").Cells(i, 1).Value <> Sheets("日檢核").Range("J2") Then
For a = 1 To j - 1
'日期匯出
Sheets("日累積").Cells(i + a, 1).Value = Sheets("日檢核").Range("J2")
Next a
With ThisWorkbook.Worksheets("日檢核")
Rng = .[a1].CurrentRegion.Offset(1)
ReDim Dr(UBound(Rng) - 1, 1)
For x = 1 To UBound(Dr)
Dr(x, 1) = .[J2]
Next x
End With
With ThisWorkbook.Worksheets("日累積")
.[A65535].End(xlUp).Offset(1).Resize(UBound(Dr), 1).Value = Dr
.[B65535].End(xlUp).Offset(1).Resize(UBound(Rng), UBound(Rng, 2)).Value = Rng
End With
MsgBox "資料匯出完成！" ' 匯出完成訊息
End If
End Sub

複製代碼

[發問] 累積報表 修正語法