如題,我使用 Excel 2013。
可能因為儲存格使用到大量重複的公式,造成檔案肥大,如下圖,
於是每次開啟檔案都要等上 30分鐘...
請問有方法將公式轉換成 VBA,以減少檔案大小,進而增加開啟檔案的速度嗎?
我使用公式=INDEX(A!$A$2:$A$100,MATCH(B!A1,A!$D$2:$D$100)+1,1),
欲完成不同表格間的比對和填值,說明如下:
step1. 將表 B儲存格 A1的值 =0.487971,在表 A的 D欄的值比對,
找到(表B, A1)=0.487971 >(表A, D15)=0.446153846。
step2. 依據 step1結果,找到表 A的 D15對應在 A欄的位置 A15,再+1=A16。
step3. 將表 A儲存格 A16的值,填入表 C的 A2儲存格。
依照前述步驟,繼續將表 B2的 A2的值,在表 A的 D欄的值比對,
找到對應在表 A 的 A欄的位置 +1後,再將儲存格的值填入表 C的 A3。
以此類推。
表A
表B
表C
另外,附上問題舉例使用的檔案(檔案大小 12.9KB):https://drive.google.com/file/d/1W_VFzmJqCMEWHitCfXPFyxY6GpFnAYC1/view?usp=sharing
感謝大家的幫忙!祝平安喜樂。
有點複雜有些地方可能理解錯誤。
優化檔案開啟速度
有三張資料表
表A:來源資料表
表B:搜尋
表C:搜尋結果
在表A搜尋表B,產出結果表C。
用公式查到值以後 > 選擇性貼上/值
Sub 跨資料表查詢()
'宣告
'資料表設定:表A,表B,表C
Dim shA, shB, shC, fml As String
shA = "A"
shB = "A"
shC = "A"
'公式設定
fml = "=INDEX($B$5:$B$9,MATCH(F5,$C$5:$C$9)+1,1)"
'輸出範圍
Set result = Sheets(shC).Range("I5: J7")
'處理過程
endRow = result.Rows.Count
result.Rows(1).Formula = fml
For reRow = 2 To endRow
result.Rows(1).Copy
With result.Rows(reRow)
.PasteSpecial
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Next reRow
With result.Rows(1)
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
End Sub
感謝回答!原來公式可以這樣放上去 VBA啊~
我後來 google一些別人的例子,以原本的問題舉例檔案,
將表 B儲存格在欄和列的參照位置,用兩個迴圈去找:
Sub FindValue()
Dim SearchRange As Range
Dim ARow As Long
Dim BRow As Long
Dim BCol As Long
Dim CRow As Long
Dim CCol As Long
Dim BEndRow As Long
Dim BEndCol As Long
Set SearchRange = Sheets("A").Range("D2:D30") ' 在表 A要查找的範圍
BCol = 1
CCol = 1
EndBCol = Range("A1").End(xlToRight).Column ' 找表 B最後一欄的資料
Do Until BCol > EndBCol
BRow = 1
CRow = 2
EndBrow = Sheets("B").Range("A1").End(xlDown).Row ' 找表 B最後一列的資料
Do Until BRow > EndBrow
For Each cell In SearchRange
If cell.Value > Sheets("B").Cells(BRow, BCol).Value Then
ARow = cell.Row ' 找(表 A, D2:D30) >表 B儲存格的值的位置
Exit For
End If
Next
Sheets("C").Cells(CRow, CCol) = Sheets("A").Range("A" & ARow).Value '把表 A, A欄的值填入表 C
BRow = BRow + 1
CRow = CRow + 1
Loop
BCol = BCol + 1
CCol = CCol + 1
Loop
End Sub
我也不確定這樣做是否正確?
不過可以順利執行預期完成的工作,
檔案也成功瘦身到原本的一半左右大小 XD
你可以玩看看「錄製巨集」
好的,感謝提供訊息。
其實寫法很多種, 我也不是很熟, 我用最笨的寫法,
"來杯拿鐵"的比較符合你要的答案, 我是來串門子練功夫
還有一種做法是, 寫深一點, 程式寫在A活頁簿, 然後指定路徑+檔名, 去執行
Sub MAIN()
Dim rng As Object '物件
Dim dataRow As Integer '表B 的資料列數
Dim dataCol As Integer '表B 的資料欄數
Dim xRow As Integer '表B列, 用來循序讀取列資料
Dim xCol As Integer '表B欄, 用來循序移動欄座標讀取資料
Dim fData As Double '要比對的表B值
Dim fRow As Integer '比對表A值, 符合條件的列數
Dim dataEnd As Integer '表A 的資料列數
Dim cRow As Integer '要寫入表C 的列的位置
Application.ScreenUpdating = False ' 關閉螢幕的顯示
'--------------------------------------------------
'填入表C 的標題列, 有點多餘, 看你要不要用
Worksheets("表C").Range("A1").Value = "1A"
Worksheets("表C").Range("B1").Value = "1B"
Worksheets("表C").Range("C1").Value = "1C"
Worksheets("表C").Range("D1").Value = "1D"
Worksheets("表C").Range("E1").Value = "1E"
'--------------------------------------------------
' 切換到表A, 取得最後的資料列位置
Worksheets("表A").Activate
dataEnd = Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row
' 切換到表B 最後的資料列及欄位數
Worksheets("表B").Activate
dataRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row ' 取得資料最後列
dataCol = Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column ' 取得資料最右欄
For xCol = 1 To dataCol '表B 欄
cRow = 1 '表C 的欄題列值, 0表示沒有標題列
For xRow = 1 To dataRow ' 表B 列
' 取得表B RANGE(A1~A最後列)的值, CELLS(列, 欄), 例 CELLS(1, "A") = A1 或 CELLS(1,1) = A1
fData = Worksheets("表B").Cells(xRow, xCol).Value
' 開始比對資料
Worksheets("表A").Activate
For Each rng In Range("D2:D" & dataEnd)
If rng.Text > fData Then
fRow = rng.Row ' 符合比對條件的資料列數值
cRow = cRow + 1 ' 寫入表C的列數值
' 把指定的表A值填入表C
Worksheets("表C").Cells(cRow, xCol).Value = Worksheets("表A").Cells(fRow, "A").Value
Exit For '結束此次比對
End If
Next
Worksheets("表B").Activate
Next xRow
Next xCol
Application.ScreenUpdating = True
End Sub