[發問] Excel VBA篩選處理資料加速問題

各位大大好，小弟剛使用VBA不久，目前只會打簡單的function搭配錄製巨集

現在遇到的問題是，目前用迴圈讀檔，然後篩選後刪除不要的資訊
處理的資料是每天720個XML檔，每個檔案約莫900筆的資料 (一天約六十萬筆資料)
然而處理前幾個XML檔很快，但到後來就會越來越慢ex兩小時只跑了約540個檔案

現在的想法是可能是隨著資料變多篩選跟刪除的速度都會變慢
或許可以將篩選的結果貼至新工作表能增快速度，但貼至新工作表後不知如何自動選取適當的位置貼上(不要覆蓋現有資料繼續往下貼)

希望各位大大們能給予指教與幫助，感激不盡！

附上現在的VBA code與相關資料 rar檔

Sub test()
'匯入xml檔_靜態
ActiveWorkbook.XmlImport URL:= _
      "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_info_0000.xml", ImportMap:= _
      Nothing, Overwrite:=True, Destination:=Range("$A$1")
ActiveWorkbook.XmlMaps("XML_Head_Map").Name = "XML_Head_Map_Info"

Sheets("工作表2").Select
'匯入xml檔_動態
ActiveWorkbook.XmlImport URL:= _
      "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_value_0000.xml", ImportMap:= _
      Nothing, Overwrite:=True, Destination:=Range("$A$1")
'刪除不需欄位
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

With ActiveWorkbook.XmlMaps("XML_Head_Map")
      .ShowImportExportValidationErrors = False
      .AdjustColumnWidth = True
      .PreserveColumnFilter = True
      .PreserveNumberFormatting = True
      .AppendOnImport = True
End With

Range("D2").Select
ActiveCell.FormulaR1C1 = "=ASC([@message])"
Columns("D:D").ColumnWidth = 41
Range("表格2[[#Headers],[欄1]]").Select
ActiveCell.FormulaR1C1 = "全形轉半形"

Range("E2").Select
ActiveCell.FormulaR1C1 = _
      "=IF(COUNTIF([@message],""*壅塞*"")+COUNTIF([@message],""*K*"")+COUNTIF([@message],""*k*"")+COUNTIF([@message],""*雨*"")+COUNTIF([@message],""*天候不佳*""),1,0)"
ActiveSheet.ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="0"
Rows("2:500000").Select
Selection.Delete Shift:=xlUp
ActiveSheet.ListObjects("表格2").Range.AutoFilter Field:=5
Range("表格2[[#Headers],[欄1]]").Select
ActiveCell.FormulaR1C1 = "含關鍵字與否"
Columns("F:F").ColumnWidth = 17


sPath = "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\"
sFile = Dir(sPath & "*.xml")
'MsgBox (sFile)
Dim i As Integer
i = 1
Do While sFile <> ""

      If sFile <> "cms_info_0000.xml" And sFile <> "cms_value_0000.xml" Then
            ActiveWorkbook.XmlMaps("XML_Head_Map").Import URL:= _
         sPath & sFile
         '動態處理
            ActiveSheet.ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="0"
            Rows("2:500000").Select
            Selection.Delete Shift:=xlUp
            ActiveSheet.ListObjects("表格2").Range.AutoFilter Field:=5

      End If
      sFile = Dir()
      i = i + 1
   Loop
End Sub

原始資料部分檔

CMS.rar (946.55 KB)

wwwlen2002

小學生 Rank: 1

帖子: 3
主題: 1
精華: 0
積分: 5
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 10
性別: 男
註冊時間: 2016-10-13
最後登錄: 2016-12-16

論壇贊助勳章

2^#

發表於 2016-11-8 16:12 | 只看該作者

Sub 巨集1()
' Timing
Dim Time0#
Time0 = Timer
' Close screenupdating to boost the procedure
Application.ScreenUpdating = False
' Import XML data (cms_info)
ActiveWorkbook.XmlImport URL:= _
"C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_info_0000.xml", ImportMap:= _
Nothing, Overwrite:=True, Destination:=Range("$A$1")
ActiveWorkbook.XmlMaps("XML_Head_Map").Name = "XML_Head_Map_Info"
' Import another XML data (cms_value)
Sheets("工作表2").Select
ActiveWorkbook.XmlImport URL:= _
"C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\cms_value_0000.xml", ImportMap:= _
Nothing, Overwrite:=True, Destination:=Range("$A$1")
' Delete unnecessary data
Columns("A:B").EntireColumn.Delete
Columns("B:B").EntireColumn.Delete
Columns("C:C").EntireColumn.Delete
' Setting the succeeding import default
With ActiveWorkbook.XmlMaps("XML_Head_Map")
.ShowImportExportValidationErrors = False
.AdjustColumnWidth = True
.PreserveColumnFilter = True
.PreserveNumberFormatting = True
.AppendOnImport = False
End With
' Deal with the string
[D1].FormulaR1C1 = "全形轉半形"
[D2].FormulaR1C1 = "=ASC([@message])"
Columns("D:D").ColumnWidth = 41
[E1].FormulaR1C1 = "含關鍵字與否"
[E2].FormulaR1C1 = _
"=IF(COUNTIF([@message],""*壅塞*"")+COUNTIF([@message],""*K*"")+COUNTIF([@message],""*k*"")+COUNTIF([@message],""*雨*"")+COUNTIF([@message],""*天候不佳*""),1,0)"
' Find dest
'Dim dest&, count&
Count = 1
[F2].FormulaR1C1 = "=SUM([含關鍵字與否])"
Count = [F2].Value
Columns("F:F").EntireColumn.Delete
dest = Count + 1
'MsgBox (dest)
' Filter
Dim i&, LR&
'dest = [F1].Value
'MsgBox (dest)
Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="1"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:P" & LR).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("工作表3").Range("A1").PasteSpecial xlPasteValues
Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5
sPath = "C:\Users\JM-ASUSCG5285\Desktop\CMS\20150101\"
sFile = Dir(sPath & "*.xml")
'MsgBox (sFile)
i = 1
Do While sFile <> ""
If sFile <> "cms_info_0000.xml" And sFile <> "cms_value_0000.xml" Then
ActiveWorkbook.XmlMaps("XML_Head_Map").Import URL:= _
sPath & sFile
If [A3].Value <> "" Then
'動態處理
[F2].FormulaR1C1 = "=SUM([含關鍵字與否])"
Count = [F2].Value
Columns("F:F").EntireColumn.Delete
dest = dest + 1
Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5, Criteria1:="1"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:P" & LR).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("工作表3").Range("A" & dest).PasteSpecial xlPasteValues
dest = dest + Count - 1
Sheets("工作表2").ListObjects("表格2").Range.AutoFilter Field:=5
End If
End If
sFile = Dir()
i = i + 1
Loop
' Parameterize/ Structure the sheet
Sheets("工作表3").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$E$" & dest), , xlYes).Name = "表格3"
Application.ScreenUpdating = True
MsgBox "執行時間 " & Timer - Time0 & " 秒", vbOKOnly
End Sub

複製代碼

爬了一些增進效率的文後
關掉screenupdating以及減少selection的使用
加上將匯入資料篩選想要資料後貼至新表格，而非在原表格篩選出不要資料刪除
速度快了非常多，約 1分半內跑完一整天的資料

目前遇到的問題是selection後的value想用transfer而非copy和paste的方式不知道怎麼處理
雖然不知道速度會再快多少，但目前結果算差強人意了
與大家分享，若有建議還請不吝提出，謝謝！

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

3^#

發表於 2016-11-9 17:17 | 只看該作者

本帖最後由 stillfish00 於 2016-11-9 17:20 編輯

回復 2# wwwlen2002
只處理cms_value_####.xml
XML_PATH 自行改為正確路徑
參考 :

Sub Test()
Dim t: t = Timer
Const XML_PATH = "C:\Users\xxxxx\Downloads\CMS\CMS\20150101"
Dim oXml As Object: Set oXml = CreateObject("msxml2.domdocument")
Dim sFile As String, sTime As String, sCmsid As String, sMessage As String
Dim oNodes As Object, arData, cnt As Long
ReDim arData(1 To 3, 1 To 1)
sFile = Dir(XML_PATH & "\")
Do While Len(sFile) > 0
If sFile Like "cms_value_####.xml" Then
oXml.Load XML_PATH & "\" & sFile
With oXml.ChildNodes(1)
sTime = .getAttribute("updatetime")
Set oNodes = .getElementsbyTagName("Info")
ReDim Preserve arData(1 To 3, 1 To UBound(arData, 2) + oNodes.Length)
For Each x In oNodes
sMessage = WorksheetFunction.Asc(x.getAttribute("message")) '全形轉半形
If HasMyKeyWords(sMessage) Then
sCmsid = x.getAttribute("cmsid")
cnt = cnt + 1
arData(1, cnt) = sTime
arData(2, cnt) = sCmsid
arData(3, cnt) = sMessage
End If
Next
ReDim Preserve arData(1 To 3, 1 To cnt)
End With
End If
sFile = Dir()
Loop
If cnt > 0 Then
With Sheets.Add(After:=Sheets(Sheets.Count))
.[a1].Resize(1, 3) = Array("updatetime", "cmsid", "message")
.[a2].Resize(cnt, 3) = Application.Transpose(arData)
.UsedRange.Columns.AutoFit
End With
End If
MsgBox "執行時間 " & Timer - t & " 秒", vbOKOnly
End Sub
Function HasMyKeyWords(s As String) As Boolean
For Each x In Array("壅塞", "K", "k", "雨", "天候不佳")
If InStr(1, s, x) > 0 Then
HasMyKeyWords = True
Exit Function
End If
Next
HasMyKeyWords = False
End Function

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

[發問] Excel VBA篩選處理資料加速問題

[發問] Excel VBA篩選處理資料加速問題

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]