常用代码归集

jsgj2023

http://club.excelhome.net/thread-1375631-1-1.html
对选择区域的所有行的A-G列填充红色
Private Sub Worksheet_SelectionChange(ByVal T As Range)
    If T.Column > 7 Then Exit Sub
    If T.Row > 18 Then Exit Sub
    [a:g].Font.ColorIndex = 0
    Dim arr(1 To 2)
    R1 = Cells(Rows.Count, 1).End(xlUp).Row
    r2 = T.Address
    If InStr(r2, ":") Then
        s1 = Split(r2, ":")
        For x = 0 To UBound(s1)
            k = k + 1
            arr(k) = Split(s1(x), "$")(2)
        Next
        Range(Cells(arr(1) * 1, 1), Cells(arr(2) * 1, 7)).Font.ColorIndex = 3
    Else
        s = Split(r2, "$")(2) * 1
        Range(Cells(s, 1), Cells(s, 7)).Font.ColorIndex = 3
    End If
End Sub

jsgj2023

countif改写
http://club.excelhome.net/thread-1375735-1-1.html
Sub Adele()
    Sheet1.Activate
    Dim rng As Range, arr, brr, x&, k&, r&
    Range("a:a").Interior.ColorIndex = 0
    arr = Range("a1").CurrentRegion
    r = Cells(Rows.Count, 2).End(xlUp).Row
    brr = Range("b1:c" & r)
    For y = 1 To UBound(brr)
        If brr(y, 1) <> " " Then
            For x = 1 To UBound(arr)
                If InStr(arr(x, 1), brr(y, 1)) Then
                    k = k + 1
                     If rng Is Nothing Then Set rng = Cells(x, 1) Else Set rng = Union(rng, Cells(x, 1))
                    brr(y, 2) = k
                End If
            Next
            k = 0
        End If
    Next
    If Not rng Is Nothing Then rng.Rows.Interior.ColorIndex = 3
    Range("b1").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

jsgj2023

http://club.excelhome.net/thread-1375840-1-1.html
请问怎样使用VBA进行数据引用
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$E$2" Then Exit Sub
sname = Target.Value
    Set d = CreateObject("scripting.dictionary")
     With Sheet2
        .ComboBox1.Clear
        arr = Sheet1.[a1].CurrentRegion
        For i = 2 To UBound(arr)
        If arr(i, 1) = sname Then
            If Not d.exists(arr(i, 2)) Then
                d(arr(i, 2)) = ""
                .ComboBox1.AddItem arr(i, 2)
            End If
        End If
        Next
    End With
End Sub

jsgj2023

http://club.excelhome.net/thread-1375840-1-1.html
请问怎样使用VBA进行数据引用

使用有效性
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$E$2" Then Exit Sub
sname = Target.Value
    Set d = CreateObject("scripting.dictionary")
     With Sheet2
        arr = Sheet1.[a1].CurrentRegion
        For i = 2 To UBound(arr)
        If arr(i, 1) = sname Then
            If Not d.exists(arr(i, 2)) Then
                d(arr(i, 2)) = ""
                With .Range("B5").Validation
                    .Delete
                    .Add 3, 1, 1, Join(d.keys, ",")
                End With
            End If
        End If
        Next
    End With
End Sub

jsgj2023

汇总工作簿获取其他工作簿中的数据
http://club.excelhome.net/thread-1376520-1-1.html
Sub Adele()
Dim arr, brr, myPath$, d As Object, d1 As Object
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\样本-数据表"
f = Dir(myPath & "\*.xls*")
      Do While f <> ""
          If f <> ThisWorkbook.Name Then
              Set wb = Workbooks.Open(myPath & "\" & f)
              For Each sht In ActiveWorkbook.Worksheets
                  With sht
                      arr = .Range("a1").CurrentRegion
                      For x = 2 To UBound(arr)
                        If Len(arr(x, 2)) Then
                            d1(arr(x, 2)) = d1(arr(x, 2)) + arr(x, 10)
                            s = arr(x, 2) & "," & arr(x, 3)
                            d(s) = d(s) + arr(x, 10)
                        End If
                      Next x
                     End With
                 Next sht
                 wb.Close False
             End If
             f = Dir
         Loop
         On Error Resume Next
         For y = 4 To Cells(Rows.Count, 2).End(3).Row
            If d1.exists(Cells(y, 2).Value) Then Cells(y, 4) = d1(Cells(y, 2).Value) / 100000000
            s1 = Cells(y, 1).Value & "," & Cells(y, 2)
            If d.exists(s1) Then Cells(y, 4) = d(s1) / 100000000
         Next
Application.ScreenUpdating = True
End Sub

jsgj2023

数据拆分问题，希望大神们多多帮助
'http://club.excelhome.net/thread-1376659-1-1.html
Sub Adele()
    Dim arr, brr(), d As Object, crr(), Ma, Mat
    arr = Sheet1.Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr))
    Set d = CreateObject("Scripting.dictionary")
    Set Reg = CreateObject("Vbscript.RegExp")
    With Reg
        .Global = True
        .Pattern = "(?!适合)([\u4e00-\u9fa5]{2,})([0-9]?)|[A-Za-z]+"
    End With
    For x = 2 To UBound(arr)
        kk = kk + 1
        Set Mat = Reg.Execute(Mid(arr(x, 2), 6))
        For Each Ma In Mat
            m = m + 1: k = 0
            For y = 1 To Ma.submatches.Count
                k = k + 1
                If Ma.submatches(y - 1) = "" Then s = s & "," & Ma Else s = s & "," & Ma.submatches(y - 1)
            Next
        Next Ma
        brr(kk) = s: s = ""
    Next
    ReDim crr(1 To UBound(brr), 1 To 10)
    For a = 1 To UBound(brr)
        If Len(brr(a)) Then
            ss = Split(brr(a), ",")
            If UBound(ss) = 10 Then
                crr(a, 1) = ss(1): crr(a, 2) = ss(5): crr(a, 3) = ss(9): crr(a, 4) = ss(2) / 2
                crr(a, 5) = ss(1): crr(a, 6) = ss(7): crr(a, 7) = ss(9): crr(a, 8) = ss(2) / 2
                crr(a, 9) = ss(3): crr(a, 10) = ss(4)
            Else
                crr(a, 1) = ss(1): crr(a, 2) = ss(5): crr(a, 3) = ss(7): crr(a, 4) = ss(2)
                crr(a, 9) = ss(3): crr(a, 10) = ss(4)
            End If
        End If
    Next
Sheet3.Range("a23").Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub

jsgj2023

如何把单元格数据批量生成文本文件
http://club.excelhome.net/thread-1377077-1-1.html
Sub Adele()
    Dim MyFile As Object, MyStr As String, r%, c%
    With Sheet1
            For r = 2 To .UsedRange.Rows.Count
            Set MyFile = CreateObject("Scripting.FileSystemObject") _
            .OpenTextFile(ThisWorkbook.Path & "\" & Cells(r, 2) & ".txt", 2, True)
                MyStr = ""
                For c = 1 To .UsedRange.Columns.Count
                    MyStr = MyStr & .Cells(r, c) & ","
                Next
                MyStr = Left(MyStr, (Len(MyStr) - 1))
                MyFile.WriteLine (MyStr)
            Next
        MyFile.Close
    End With
End Sub

mielala125

性痴则其志凝，故书痴者文必工，艺痴者技必良。
世之落拓而无成者，皆自谓不痴者也。

xiaoxiaoli61

收藏了，感谢楼主分享

学不完用不尽

谢谢分享。