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

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

複製代碼

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

複製代碼