麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] [資料區域的選擇]含公式但無數值的儲存格視為空白 [打印本頁]

作者: jackson7015 時間: 2012-2-7 21:06 標題: [資料區域的選擇]含公式但無數值的儲存格視為空白

翻了舊文,找到一個適用的,但是不會套用

請問如何將Sheets("日報表").Range("B3")內的資料
複製到Sheets("綜合資料庫").Range("B65536")

套用下列函式
lastRow = 65536 - Application.CountBlank(Columns(1))
[A1].Resize(lastRow).Copy

作者: GBKEE 時間: 2012-2-8 07:28

回復 1# jackson7015
你說的有的些模糊,上傳檔案說清楚吧.

作者: jackson7015 時間: 2012-2-8 14:12

本帖最後由 jackson7015 於 2012-2-8 14:15 編輯

回復 2# GBKEE

附上檔案
[attach]9495[/attach]

1.
B5:B1000都有公式,要將日報表的B3複製到資料庫的B列無顯示日期的第一格空格

2.
日期可否只複製儲存格顯示的"當天日期",而非B3的TODAY()

作者: GBKEE 時間: 2012-2-8 17:47

回復 3# jackson7015
試試看

Sub Ex()
Dim Ar(), Rng As Range, Xi As Integer
With Sheets("日報表")
Set Rng = .Range("d7", .[d7].End(xlDown)) '資料範圍: B欄有料的列
ReDim Ar(1 To Rng.Count, 1 To 10) '陣列的大小 1 To 10 => 資料範圍 B欄:K欄
For Xi = 1 To Rng.Count
Ar(Xi, 1) = Date '日期
Ar(Xi, 2) = .Cells(Rng(Xi).Row, "B") '編號
Ar(Xi, 3) = .Cells(Rng(Xi).Row, "N") '備註
Ar(Xi, 4) = .Cells(Rng(Xi).Row, "D") '地點
S = "=IF(RC[4]=1,""查無"",IF(RC[3]=1,""成案"" & SUM(RC[6]:RC[9])&""KW"",""""))"
Ar(Xi, 5) = S '成案
Ar(Xi, 6) = .Cells(Rng(Xi).Row, "G")
Ar(Xi, 7) = .Cells(Rng(Xi).Row, "H")
Ar(Xi, 8) = .Cells(Rng(Xi).Row, "I")
Ar(Xi, 9) = .Cells(Rng(Xi).Row, "J")
' Ar(Xi, 10) = .Cells(Rng(Xi).Row, "n") ' ** 請問這裡要寫些什麼? **
Next
End With
With Sheets("綜合資料庫")
.Range("B5:O" & Rows.Count) = "" '清除資料
.[B5].Resize(Rng.Count, 10) = Application.Transpose(Application.Transpose(Ar))
'轉置陣列填入:資料
End With
End Sub

複製代碼

作者: jackson7015 時間: 2012-2-8 19:09

本帖最後由 jackson7015 於 2012-2-8 19:17 編輯

回復 4# GBKEE

五體投地的感謝GBKEE版主..

這工作表想了好幾天快想破頭了..

要求的問題只有1.2個，卻把整篇都幾乎解決了..

小弟還有些問題，資料庫是日報表的累計

所以可以不清除資料庫，而是累計的方式繼續填入資料庫嗎

附上檔案[attach]9500[/attach]

Sub Ex()
Dim Ar(), Rng As Range, Xi As Integer
With Sheets("日報表")
Set Rng = .Range("d7", .[d7].End(xlDown)) '資料範圍: B欄有料的列
ReDim Ar(1 To Rng.Count, 1 To 14) '陣列的大小 1 To 14 => 資料範圍 B欄:O欄
For Xi = 1 To Rng.Count
Ar(Xi, 1) = Date '日期
Ar(Xi, 2) = .Cells(Rng(Xi).Row, "B") '編號
Ar(Xi, 3) = .Cells(Rng(Xi).Row, "N") '備註
Ar(Xi, 4) = .Cells(Rng(Xi).Row, "D") '地點
S = "=IF(RC[4]=1,""查無"",IF(RC[3]=1,""成案"" & SUM(RC[6]:RC[9])&""KW"",""""))"
Ar(Xi, 5) = S '成案
Ar(Xi, 6) = .Cells(Rng(Xi).Row, "E") 　'主要
Ar(Xi, 7) = .Cells(Rng(Xi).Row, "F") 　'非主要
Ar(Xi, 8) = .Cells(Rng(Xi).Row, "G") 　'是
Ar(Xi, 9) = .Cells(Rng(Xi).Row, "H")　'否
KK = "=IF(COUNTA(RC[-1]),""是"",IF(COUNTA(RC[-2]),""否"",""""))"
Ar(Xi, 10) = KK
Ar(Xi, 11) = .Cells(Rng(Xi).Row, "I") 　'燈
Ar(Xi, 12) = .Cells(Rng(Xi).Row, "J")　'力
Ar(Xi, 13) = .Cells(Rng(Xi).Row, "K")　'燈
Ar(Xi, 14) = .Cells(Rng(Xi).Row, "L")　'力
' Ar(Xi, 10) = .Cells(Rng(Xi).Row, "n") ' ** 請問這裡要寫些什麼? **
' Ar(Xi, 10) = .Cells(Rng(Xi).Row, "n") '的部分是"是否成案的公式"=IF(COUNTA($I3),"是",IF(COUNTA($J3),"否",""))
Next
End With
With Sheets("綜合資料庫")
.Range("B5:O" & Rows.Count) = "" '清除資料
.[B5].Resize(Rng.Count, 10) = Application.Transpose(Application.Transpose(Ar))
'轉置陣列填入:資料
End With
End Sub

複製代碼

還有上面

Set Rng = .Range("d7", .[d7].End(xlDown))

複製代碼

這個程式碼中的.[d7]是代表什麼意思？

作者: GBKEE 時間: 2012-2-8 20:17

本帖最後由 GBKEE 於 2012-2-8 20:46 編輯

回復 5# jackson7015

With Sheets("綜合資料庫").Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Resize(Rng.Count, UBound(AR, 2)) = Application.Transpose(Application.Transpose(AR))
End With

複製代碼

[ ] 看這裡 ...

作者: jackson7015 時間: 2012-2-8 21:36

回復 6# GBKEE

大略了解意思了，剩下的那個逗點再好好研究

感謝版主的解惑，獲益良多

也謝謝版主直接幫小弟的表格細調完整:loveliness:

作者: jackson7015 時間: 2012-2-9 18:55

回復 6# GBKEE

想在跟GBKEE大請益

可以將

Ar(Xi, 1) = Date '日期

複製代碼

套用日報表的"B3",的日期嗎

因為有時會因為當天無法作業，所以隔天做他日的日報，所以不會為當日日期

作者: GBKEE 時間: 2012-2-9 21:30

回復 8# jackson7015
可以ㄚ不過日報表 B3=TODAY() 還是當天的日期

作者: jackson7015 時間: 2012-2-9 21:59

本帖最後由 jackson7015 於 2012-2-9 22:06 編輯

回復 9# GBKEE

如果所需要的日期不是當日,[B3]我會設定TODAY()-N來當作日報表的日期格式

這樣感覺比較不會破壞日期格式

如果要將 Ar(Xi, 1) = Date 更改成以日報表的[B3]所顯示的日期為數據的話

請問 Date 該改成什麼 ?

因為不像其他列式一樣是整列去做COPY所以好像不能使用 .Cells(Rng(Xi).Row, "B3"

小弟只會舉一反一，希望能多多指教

PS.有點回歸到原問題的討論,只複製B3顯示的日期,而非公式的TODAY()

作者: GBKEE 時間: 2012-2-10 08:16

回復 10# jackson7015
Ar(Xi, 1) = .[B3] '日期
，剩下的那個逗點再好好研究

With [10].Font
.Name = "新細明體"
.FontStyle = "標準"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With

複製代碼

作者: jackson7015 時間: 2012-2-10 15:56

回復 11# GBKEE

瞭解了，自己也試過[B3]，卻出現錯誤，少一個逗點真的就差好多

感謝版主指導

作者: jackson7015 時間: 2012-2-14 17:05

回復 11# GBKEE

這兩天新增了一些項目，可是忽然出現第六行＂溢位＂錯誤訊息

可以麻煩幫忙看看是怎樣的錯誤嗎

Sub 累計日報表資料()
If MsgBox("是否執行複製？", vbYesNo) = vbNo Then Exit Sub
Dim Ar(), Rng As Range, Xi As Integer
With Sheets("日報表")
Set Rng = .Range("d7", .[d7].End(xlDown)) '資料範圍: B欄有資料的列
ReDim Ar(1 To Rng.Count, 1 To 20) '陣列的大小 1 To 20 => 資料範圍 B欄:V欄
For Xi = 1 To Rng.Count
Ar(Xi, 1) = .[B3] '日期
Ar(Xi, 2) = .Cells(Rng(Xi).Row, "B") '編號
Ar(Xi, 3) = .Cells(Rng(Xi).Row, "N") '電
Ar(Xi, 4) = .Cells(Rng(Xi).Row, "D") '地點
SS = "=IF(RC[4]=1,""查無"",IF(RC[3]=1,""成案"" & SUM(RC[6]:RC[9])&""KW"",""""))"
Ar(Xi, 5) = SS '是否成案
Ar(Xi, 6) = .Cells(Rng(Xi).Row, "E") '密
Ar(Xi, 7) = .Cells(Rng(Xi).Row, "F") '非密
KK = "=IF(COUNTA(RC[+1]),""是"",IF(COUNTA(RC[+2]),""否"",""""))"
Ar(Xi, 8) = KK '現場檢驗結果
Ar(Xi, 9) = .Cells(Rng(Xi).Row, "G") '是
Ar(Xi, 10) = .Cells(Rng(Xi).Row, "H") '否
Ar(Xi, 11) = .Cells(Rng(Xi).Row, "I") '燈(惡
Ar(Xi, 12) = .Cells(Rng(Xi).Row, "J") '力(惡
Ar(Xi, 13) = .Cells(Rng(Xi).Row, "K") '燈(非惡
Ar(Xi, 14) = .Cells(Rng(Xi).Row, "L") '力(非惡性
Ar(Xi, 15) = .Cells(Rng(Xi).Row, "A") '項目
Ar(Xi, 16) = .Cells(Rng(Xi).Row, "O") '營業
Ar(Xi, 17) = .Cells(Rng(Xi).Row, "R") '行業別
Ar(Xi, 18) = .Cells(Rng(Xi).Row, "Q") '方式
Ar(Xi, 19) = .Cells(Rng(Xi).Row, "S") '移送
Ar(Xi, 20) = .Cells(Rng(Xi).Row, "P") '部門
Next
End With
With Sheets("綜合資料庫").Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Resize(Rng.Count, UBound(Ar, 2)) = Application.Transpose(Application.Transpose(Ar))
End With
End Sub

複製代碼

ReDim Ar(1 To Rng.Count, 1 To 20)
出現錯誤

作者: GBKEE 時間: 2012-2-14 18:01

回復 13# jackson7015
傳檔看看

作者: jackson7015 時間: 2012-2-15 07:49

回復 14# GBKEE

之後要出差幾天

先附上檔案

[attach]9588[/attach]

作者: GBKEE 時間: 2012-2-15 08:28

回復 15# jackson7015
Xi As Integer  這裡宣告 Integer 變數係以範圍為 -32,768 到 32,767 之 16 位元 (2 個位元組) 數字的形式儲存
修改為
Xi As Long Long (長整數)變數係以範圍從 -2,147,483,648 到 2,147,483,647 之 32 位元 (4 個位元組) 有號數字形式儲存。Long 的型態宣告字元為 &。

Sub 累計日報表資料()
  '  *** If MsgBox("是否執行複製？", vbYesNo) = vbNo Then Exit Sub  移到下方
Dim Ar(), Rng As Range, Xi As Long
With Sheets("日報表")
      Set Rng = .Range("d7", .[d7].End(xlDown))  '資料範圍: B欄有資料的列
      ' *** 加上判斷日報表沒有資料  ****
      If Application.CountA(Rng) = 0 Then MsgBox "日報表沒有資料 !!!": Exit Sub
      If MsgBox("是否執行複製？", vbYesNo) = vbNo Then Exit Sub
      ReDim Ar(1 To Rng.Count, 1 To 20)       '陣列的大小 1 To 20 => 資料範圍 B欄:V欄
      For Xi = 1 To Rng.Count    '<-是這裡錯誤  Xi As Integer
'日報表沒有資料  Rng.Count =Rows.Count-7 : 2003版 65,536 - 7  > 32,767

作者: jackson7015 時間: 2012-2-20 13:48

本帖最後由 jackson7015 於 2012-2-20 13:50 編輯

回復 16# GBKEE

今天測試了修改後的巨集

如果再日報表內只有1欄(如檔)資料,則使用巨集後會出現了錯誤訊息"執行階段錯誤1004"

這個錯誤只有在日報表只有一則資料才會發生,多於1則不會

附上檔案和代碼

[attach]9669[/attach]

Sub 累計日報表資料()
Dim Ar(), Rng As Range, Xi As Long
With Sheets("日報表")
Set Rng = .Range("d7", .[d7].End(xlDown)) '資料範圍: B欄有資料的列
If Application.CountA(Rng) = 0 Then MsgBox "日報表沒有資料 !!!": Exit Sub '判斷日報表有沒有資料
If MsgBox("是否執行複製？", vbYesNo) = vbNo Then Exit Sub
ReDim Ar(1 To Rng.Count, 1 To 20) '陣列的大小 1 To 20 => 資料範圍 B欄:V欄
For Xi = 1 To Rng.Count
Ar(Xi, 1) = .[B3] '日期
Ar(Xi, 2) = .Cells(Rng(Xi).Row, "B") '實調書編號
Ar(Xi, 3) = .Cells(Rng(Xi).Row, "N") '電號
Ar(Xi, 4) = .Cells(Rng(Xi).Row, "D") '地點
SS = "=IF(RC[4]=1,""查無竊電"",IF(RC[3]=1,""稽查成案"" & SUM(RC[6]:RC[9])&""KW"",""""))"
Ar(Xi, 5) = SS '是否成案
Ar(Xi, 6) = .Cells(Rng(Xi).Row, "E") '密告
Ar(Xi, 7) = .Cells(Rng(Xi).Row, "F") '非密告
KK = "=IF(COUNTA(RC[+1]),""是"",IF(COUNTA(RC[+2]),""否"",""""))"
Ar(Xi, 8) = KK '現場檢驗結果
Ar(Xi, 9) = .Cells(Rng(Xi).Row, "G") '是
Ar(Xi, 10) = .Cells(Rng(Xi).Row, "H") '否
Ar(Xi, 11) = .Cells(Rng(Xi).Row, "I") '燈(惡性
Ar(Xi, 12) = .Cells(Rng(Xi).Row, "J") '力(惡性
Ar(Xi, 13) = .Cells(Rng(Xi).Row, "K") '燈(非惡性
Ar(Xi, 14) = .Cells(Rng(Xi).Row, "L") '力(非惡性
Ar(Xi, 15) = .Cells(Rng(Xi).Row, "A") '項目
Ar(Xi, 16) = .Cells(Rng(Xi).Row, "O") '營業
Ar(Xi, 17) = .Cells(Rng(Xi).Row, "R") '行業別
Ar(Xi, 18) = .Cells(Rng(Xi).Row, "Q") '竊電方式
Ar(Xi, 19) = .Cells(Rng(Xi).Row, "S") '移送情形
Ar(Xi, 20) = .Cells(Rng(Xi).Row, "P") '提報部門
Next
End With
With Sheets("綜合資料庫").Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Resize(Rng.Count, UBound(Ar, 2)) = Application.Transpose(Application.Transpose(Ar))
End With
End Sub

複製代碼

.Resize(Rng.Count, UBound(Ar, 2)) = Application.Transpose(Application.Transpose(Ar))
第34行出現錯誤

請問要修改什麼呢?

而原本的Integer 變數,為什麼不直接使用Long變數就好,執行位元組較多
是否有版本的問題而不能直接使用Long變數?

作者: GBKEE 時間: 2012-2-20 14:25

回復 17# jackson7015

With Sheets("日報表")
If .Cells(Rows.Count, "D").End(xlUp).Row = 4 Then '偵查是否資料
MsgBox "日報表沒有資料 !!"
Exit Sub
End If
Set Rng = .Range("d7", .Cells(Rows.Count, "D").End(xlUp)) ' **** 這裡改成由下往上資料範圍: B欄有資料的列
If Application.CountA(Rng) = 0 Then MsgBox "日報表沒有資料 !!!": Exit Sub '判斷日報表有沒有資料
If MsgBox("是否執行複製？", vbYesNo) = vbNo Then Exit Sub

複製代碼

作者: jackson7015 時間: 2012-2-20 17:02

回復 18# GBKEE

執行正常了，感謝版主

想問個問題，前面已經有函數判斷有無資料了，為何第７行還要判斷一次？

我刪除後好像也是能正常執行

If Application.CountA(Rng) = 0 Then MsgBox "日報表沒有資料 !!!": Exit Sub '判斷日報表有沒有資料

複製代碼

作者: GBKEE 時間: 2012-2-21 07:44

回復 19# jackson7015
你說的有理那就是多餘了

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