vba操作VCF、有效性等

VCF导入、精简：

Sub inputVcf() '放在sheet1用于导入
    Application.ScreenUpdating = False
    Sheet1.Select
    Cells.Delete
    s = InputBox("输入vcf文件路径", "导入vcf")
    
    If s = "" Then Exit Sub
    Application.CutCopyMode = False
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & s, Destination:=Range("$A$1"))
        .Name = "00001"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierNone
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    For i = UsedRange.Rows.Count To 1 Step -1
        If Left(Cells(i, 1), 2) = "EN" Or Left(Cells(i, 1), 2) = "BE" Or Left(Cells(i, 1), 2) = "N:" Or Left(Cells(i, 1), 2) = "VE" Then
            Rows(i & ":" & i).Delete
        End If
    Next
    UsedRange.Replace "*:", ""
    m = 0
    n = 3
    j = 1
    For i = 1 To UsedRange.Rows.Count
        If IsNumeric(Left(Cells(i, 1), 1)) = False Then
            m = m + 1
            Cells(m, 2) = Cells(i, 1)
            n = 3
        Else
            Cells(m, n) = Cells(i, 1)
            n = n + 1
        End If
    Next
End Sub

Sub setVcf() '放在sheet2用于生成
    Application.ScreenUpdating = False
    s = ""
    For i = 1 To UsedRange.Rows.Count
        s = s & "BEGIN:VCARD" & vbCrLf & "VERSION:3.0" & vbCrLf & "FN:" & Cells(i, 1) & vbCrLf
        For j = 2 To 4
            If Cells(i, j) = "" Then
                
            ElseIf Left(Cells(i, j), 1) = "1" Then
                s = s & "TEL;TYPE=手机:" & Cells(i, j) & vbCrLf
            Else
                s = s & "TEL;TYPE=固话:" & Cells(i, j) & vbCrLf
            End If
        Next j
        s = s & "END:VCARD"
    Next i
    Open "D:\1.txt" For Output As #1
    Print #1, s
    Close #1
End Sub

数据有效性：sheet1 A列分类，B列为细项；实现在sheet2A列输入分类后，同行B列下拉框显示有效值。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)  '放在sheet2
    If Target.Column = 2 And Cells(Target.Row, 1) <> "" Then
        Sheet1.Range("C:C").Delete
        j = 1
        For i = 1 To Sheet1.UsedRange.Rows.Count
            If Sheet1.Cells(i, 1) = Cells(Target.Row, 1) Then
                Sheet1.Cells(j, 3) = Sheet1.Cells(i, 2)
                j = j + 1
            End If
        Next i
        
        Dim cnum
        cnum = Application.WorksheetFunction.CountA(Sheet1.Range("c:c"))
        If cnum >= 1 Then
            With Selection.Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=Sheet1!C1:C" & cnum
            End With
        End If
    End If
End Sub

网页抓取，不实用，约束大。

Sub getPage()
    Application.ScreenUpdating = False
    Dim http, Pols, Arr, i, u
    Set http = CreateObject("Microsoft.XMLHTTP")
    j = UsedRange.Rows.Count + 1
    For i = 1 To 11
      http.Open "POST", "http://www.web.com/index.php?number=" & i, False
      http.send ""
      If http.Status = 200 Then
        Cells(j, 1) = http.responseText
        j = j + 1
      End If
    Next
    Set http = Nothing
End Sub

WORD更改特定字符颜色。

Sub changeColor()
    Dim i
    i = 0
    Do
        If i >= ActiveDocument.Content.End - 1 Then Exit Do
        If ActiveDocument.Range(i, i + 1).Text = "★" Then
            ActiveDocument.Range(i, i + 1).Font.ColorIndex = wdRed
        End If
        i = i + 1
    Loop
End Sub