VBA个人总结

Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
   If Sheets(j).Name <> ActiveSheet.Name Then
       X = Range("A65536").End(xlUp).Row + 1
       Sheets(j).UsedRange.Copy Cells(X, 1)
   End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
End Sub

Sub 多行多列求和()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
m = Sheets(1).[a65536].End(xlUp).Row
For i = 3To m Step 3
For j = 3To 6
Cells(i, j) = Cells(i - 1, j) + Cells(i - 2, j)
Next j
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "@风里孜然味"
End Sub

Sub 每隔两行插入一行()
Dim i
For i = 1 To Sheet1.Range("a3000").End(3).Row * 3
    Rows(i & ":" & i + 0).Select
i = i + 2
    Selection.Insert Shift:=xlDown
    Next
End Sub


  Sub 查找并在该行后插入一行()
      Dim rng As Range, rng1 As Range, rng2 As Range
      Set rng1 = Cells.Find("中国", , , xlWhole) '完全匹配
      Set rng = rng1
      Set rng2 = rng1
      Do
        Set rng2 = Cells.FindNext(rng2)
If rng2.Address = rng1.Address Then
rng.Select
For Each c In Selection.Rows
Rows(c.Row + 1).Select
Selection.Insert Shift:=xlDown
Next
        End
        Else
            Set rng = Union(rng, rng2)
        End If
      Loop
  End Sub

Sub 在查找的行下插入一行byLzf()
Dim k, i, s
s = Range("a65536").End(3).Row
k = 1
For i = 1 To 10000 Step 1
    k = Range("b" & k & ":a" & s).Find("合计", , , xlWhole).Row
    Rows(k + 1).Insert Shift:=xlDown
    k = k + 1
    s = s + 1
    If k >= s Or Range("b" & k & ":a" & s).Find("合计", , , xlWhole) Is Nothing Then
       Exit For
    End If
Next
MsgBox "结束"
End Sub

//首字母
Function pinyin(p As String) As String
i = Asc(p)
Select Case i
Case -20319 To -20284: pinyin = "A"
Case -20283 To -19776: pinyin = "B"
Case -19775 To -19219: pinyin = "C"
Case -19218 To -18711: pinyin = "D"
Case -18710 To -18527: pinyin = "E"
Case -18526 To -18240: pinyin = "F"
Case -18239 To -17923: pinyin = "G"
Case -17922 To -17418: pinyin = "H"
Case -17417 To -16475: pinyin = "J"
Case -16474 To -16213: pinyin = "K"
Case -16212 To -15641: pinyin = "L"
Case -15640 To -15166: pinyin = "M"
Case -15165 To -14923: pinyin = "N"
Case -14922 To -14915: pinyin = "O"
Case -14914 To -14631: pinyin = "P"
Case -14630 To -14150: pinyin = "Q"
Case -14149 To -14091: pinyin = "R"
Case -14090 To -13319: pinyin = "S"
Case -13318 To -12839: pinyin = "T"
Case -12838 To -12557: pinyin = "W"
Case -12556 To -11848: pinyin = "X"
Case -11847 To -11056: pinyin = "Y"
Case -11055 To -2050: pinyin = "Z"
Case Else: pinyin = p
End Select
End Function
Function getpy(str)
For i = 1 To Len(str)
getpy = getpy & pinyin(Mid(str, i, 1))
Next i
End Function

Function MLOOKUP(str, rng)  '单元格内匹配字典表
For i = 1 To Len(str)
str = Replace(str, rng(i, 1), rng(i, 2))
Next i
MLOOKUP = str
End Function

Function GNum(str) '提取数字
    Dim regx, Strnew$
    Dim oMatches As Object
    Set regx = CreateObject("vbscript.regexp")
    regx.Pattern = "\d+"
    regx.Global = True '匹配所有
    Set oMatches = regx.Execute(str) '查找值的集合
    For i = 0 To oMatches.count - 1
    Strnew = Strnew + oMatches.Item(i).Value + ","
    Next
   Strnew = Left(Strnew, Len(Strnew) - 1)
   GNum = Strnew
End Function

Sub 合并相同内容单元格()
Dim rng As Range
Dim tem
Set rng = Selection
tem = rng.Count
    Application.DisplayAlerts = False
    For i = tem To 1 Step -1
        If rng.Cells(i, 1) = rng.Cells(i - 1, 1) Then
            Range(rng.Cells(i, 1), rng.Cells(i - 1, 1)).Merge
        End If
    Next
    Application.DisplayAlerts = True
End Sub

=COUNTA($C$17:C17)合并单元格后的编号

Function VVlOOKUP(str, rng) 'VlOOKUP多个
  Dim MRG As Range, AAA As String
  Set MRG = rng.Find(str)
  AAA = MRG.Address
  ss = Sheets(4).Cells(MRG.Row, MRG.Column + 1) + ","
  Do
    Set MRG = rng.FindNext(MRG)
    ss = ss + Sheets(4).Cells(MRG.Row, MRG.Column + 1) + ","
  Loop Until MRG.Address = AAA
  GNum = ss
End Function
Function MLOOKUP(str, rng)  '单元格内批量替换字典表 （有待改进）
For i = 1 To Len(str)
str2 = Replace(str, rng(i, 1), rng(i, 2))
If str2 <> str Then
Exit For
Else
str2 = NaN
End If
Next i
MLOOKUP = str2
End Function