[發問] (已解決)執行程式後跳出視窗?

本帖最後由 candy516 於 2011-6-3 18:22 編輯

各位前輩您好~
我用了之前Hsieh前輩幫我寫的程式篩選資料，之前都還可以用!
但現在用都會跳出一些奇怪的東西，請問有沒有人可以幫我解答一下呢?先謝謝各位前輩!^^
(因檔案太大，我先將01~09年資料刪除了，只剩2010年!)

程式碼如下

Sub ex()
On Error Resume Next
Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
Set d = CreateObject("Scripting.Dictionary")
Set sht = Sheets.Add(after:=Sheets(1))
Application.ScreenUpdating = False
With Sheet1
For Each A In .Range(.[A2], .[A65536].End(xlUp))
mystr = A & "," & Left(A.Offset(, 1), 4)
'你Sheet1的A欄是以日期格式yyyy/m/d輸入，但格式設成yyyymmdd，所以，造成非全部為8碼
'用TEXT屬性得到所見字串
d(mystr) = DateValue(Format(A.Offset(, 1).Text, "0000/00/00"))
If Err.Number <> 0 Then MsgBox A & A.Offset(, 1)
Next
End With
k = 1: r = 1
For Each ky In d.keys
y = Split(ky, ",")(1)
With Sheets(y)
Set C = .Columns("A").Find(d(ky))
Set B = .Rows(1).Find(Split(ky, ",")(0))
If Not C Is Nothing And Not B Is Nothing Then
x = Application.Max(3, C.Row - 14)
Set Rng = .Cells(x, 1).Resize(15, 1)
Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
With sht
Rng.Copy .Cells(r, k)
Rng1.Copy .Cells(r, k + 1)
.Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
End With
r = r + 15
Else
MsgBox "無此除權資料"
End If
End With
Next
Application.ScreenUpdating = True
End Sub

複製代碼

TEST 現金股利.rar (864.86 KB)

樓主熱帖

mark15jill

　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生 Rank: 3 Rank: 3

帖子: 852
主題: 79
精華: 0
積分: 918
點名: 0
作業系統: Windows 7 , XP
軟體版本: Office 2007, Office 2003,Office 2010,YoZo Office
閱讀權限: 50
性別: 男
來自: 宇宙
註冊時間: 2011-4-8
最後登錄: 2024-2-21

2^#

發表於 2011-6-3 17:27 | 只看該作者

回復 1# candy516

你有動到一些程式碼嗎???
因為就我剛剛把你的程式碼丟去乾淨EXCEL檔案內就發現好多紅字...
         mystr = A "," & Left(A.Offset(, 1), 4)
   If Err.Number <> 0 Then MsgBox A A.Offset(, 1)
   .Cells(r, 3) = y "年第" & B.Column - 1 & "筆"

紅通通..

TOP

candy516