VBA个人总结

Sub 合并当前工作簿下的所有工作表()Application.ScreenUpdating = FalseFor 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 IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"End SubSub 多行多列求和()Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume Nextm = Sheets(1).[a65536].End(xlUp).RowFor i = 3To m Step 3For j = 3To 6Cells(i, j) = Cells(i - 1, j) + Cells(i - 2, j)Next jNext iApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "@风里孜然味"End SubSub 每隔两行插入一行()Dim iFor i = 1 To Sheet1.Range("a3000").End(3).Row * 3    Rows(i & ":" & i + 0).Selecti = i + 2    Selection.Insert Shift:=xlDown    NextEnd 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 Thenrng.SelectFor Each c In Selection.RowsRows(c.Row + 1).SelectSelection.Insert Shift:=xlDownNext        End        Else            Set rng = Union(rng, rng2)        End If      Loop  End SubSub 在查找的行下插入一行byLzf()Dim k, i, ss = Range("a65536").End(3).Rowk = 1For 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 IfNextMsgBox "结束"End Sub//首字母Function pinyin(p As String) As Stringi = Asc(p)Select Case iCase -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 = pEnd SelectEnd FunctionFunction getpy(str)For i = 1 To Len(str)getpy = getpy & pinyin(Mid(str, i, 1))Next iEnd FunctionFunction MLOOKUP(str, rng)  '单元格内匹配字典表For i = 1 To Len(str)str = Replace(str, rng(i, 1), rng(i, 2))Next iMLOOKUP = strEnd FunctionFunction 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 = StrnewEnd FunctionSub 合并相同内容单元格()Dim rng As RangeDim temSet rng = Selectiontem = 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 = TrueEnd 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 = ssEnd FunctionFunction MLOOKUP(str, rng)  '单元格内批量替换字典表 （有待改进）For i = 1 To Len(str)str2 = Replace(str, rng(i, 1), rng(i, 2))If str2 <> str ThenExit ForElsestr2 = NaNEnd IfNext iMLOOKUP = str2End Function