• excel中vba简单应用

    获取工作簿中工作表名称

    1. Public Sub 获取工作簿表名称()
    2. Dim sh
    3. Dim j
    4. For Each sh In ThisWorkbook.Sheets
    5.     ThisWorkbook.Sheets("测试").Cells(1, "C").Value = sh.Name
    6.     Debug.Print sh.Name
    7. Next
    8. End Sub

    获取文件夹下所有文件的名称

    1. Public Sub 获取文件夹下的文件名称()
    2. Dim mypath, myfile, path
    3. Dim arr()
    4. Dim i As Integer
    5. 'On Error Resume Next
    6. mypath = "C:\Users\Administrator\Desktop\汇总\汇总\" 'ThisWorkbook.path + "\汇总\"
    7. myfile = Dir(mypath, vbDirectory)
    8. Do While myfile <> ""
    9.     If myfile <> "." And myfile <> ".." Then
    10.         path = mypath + myfile
    11.         i = i + 1
    12.         ReDim Preserve arr(1 To 1)
    13.         arr(i) = myfile
    14.          ThisWorkbook.Sheets("测试").Cells(1, "C").Resize(UBound(arr), 1) = Application.Transpose(arr)
    15.          Debug.Print arr(0)
    16.         myfile = Dir
    17.     Else
    18.         myfile = Dir
    19.     End If
    20. Loop
    21. End Sub

    工作簿和工作表表示

    1. Public Sub 工作簿和工作表表示()
    2. '====工作簿
    3. 'Debug.Print Windows.Count
    4. 'Debug.Print Workbooks(1).Name
    5. 'Debug.Print Workbooks("工作表-计划-2022.xlsm").Parent
    6. 'Dim i
    7. 'For i = 1 To Workbooks.Count
    8. ''    Debug.Print Workbooks(i).Name
    9. '    Sheets("测试").Cells(i, "C") = Workbooks(i).Name
    10. 'Next
    11. '工作表的表示
    12. 'Debug.Print Worksheets(1).Name
    13. 'Debug.Print Sheets(1).Name
    14. 'Debug.Print Worksheets("目录").Name
    15. 'Debug.Print Sheet1.Name
    16. 'Debug.Print ActiveSheet.Name
    17. 'Dim i
    18. 'For i = 1 To Sheets.Count
    19. ''    Debug.Print Workbooks(i).Name
    20. '    Sheets("测试").Cells(i, "C") = Sheets(i).Name
    21. 'Next
    22. 'Dim sh, k
    23. 'For Each sh In Sheets
    24. '    k = k + 1
    25. '     Sheets("测试").Cells(k, "i") = Sheets(k).Name
    26. 'Next
    27. 'For Each sh In Worksheets
    28. '    k = k + 1
    29. '     Sheets("测试").Cells(k, "i") = sh.Name
    30. 'Next
    31. '判断工作表是否存在
    32. 'Dim sh, k, sn
    33. 'For Each sh In Sheets
    34. '    sn = sh.Name
    35. '    If sn = "测试" Then
    36. '        MsgBox "存在" + sh
    37. '        Exit Sub
    38. '    End If
    39. 'Next
    40. 'MsgBox "不存在"
    41. 'Dim i
    42. 'For i = 1 To Sheets.Count
    43. '    If Sheets(i).Name = "测试" Then
    44. '          MsgBox "存在"
    45. '          Exit Sub
    46. '    End If
    47. 'Next
    48. 'MsgBox "不存在"
    49. End Sub

    ike和offset和resize和end的使用

    1. Public Sub like和offset和resize和end的使用()
    2. ''like的使用
    3. 'Dim a
    4. ''a = "abc" Like "*c"
    5. ''a = "abc" Like "?c"
    6. ''a = "abc1" Like "*c#"
    7. 'Debug.Print a
    8. 'offset 的使用
    9. 'Dim i
    10. 'For i = 2 To 8 Step 2
    11. ''    [c4:c9].Copy [c4:c9].Offset(i)
    12. '    [c4:c9].Copy [c4:c9].Offset(, 1) '偏离行、列
    13. 'Next
    14. 'resize使用
    15. '[a1].Resize(2, 3).Select
    16. 'Debug.Print [b2].CurrentRegion.Rows.Count
    17. 'Debug.Print [b2].CurrentRegion.Columns.Count
    18. '[a2].Resize(1, 2).Copy [a3].Offset(3) '偏离三行
    19. 'end 属性
    20. Dim i, j, k, l
    21. i = Cells(Rows.Count, 3).End(xlUp).Row
    22. j = Cells(Rows.Count, 3).End(xlUp).Address
    23. k = Cells(1, 3).End(xlToLeft).Column
    24. l = Cells(2, "e").End(xlToLeft).Address '最后一个行位置
    25.  
    26. Debug.Print l
    27. 'ActiveSheet.UsedRange.Select
    28. [e3].CurrentRegion.Select
    29. End Sub

    工作表合并

    1. Public Sub 工作表合并()
    2. Dim i%, rs%, rss%, st As Worksheet, zst As Worksheet
    3. Dim crs
    4. On Error Resume Next
    5. Set zst = Sheets("测试") '
    6. For i = 1 To Sheets.Count
    7.     If Sheets(i).Name <> "测试" Then
    8.          rs = Sheets(i).UsedRange.Rows.Count ' 计算复制表格行数
    9.          crs = Sheets(i).UsedRange.Columns.Count ' 计算复制表格列数
    10. '         Debug.Print crs
    11.          rss = zst.UsedRange.Rows.Count + 3 '计算目标表格的最后行位置
    12.         Sheets(i).UsedRange.Copy zst.Cells(rss, 1) '复制1-3表的数据到总表中
    13.         zst.Cells(rss, crs + 1).Resize(rs - 1) = Sheets(i).Name '将复制的表名填充
    14.     End If
    15. Next
    16. End Sub

    拆分到工作簿

    1. Sub 拆分到工作簿()
    2. Dim wk As Workbook, ss$, k%
    3. Dim sht
    4. Application.DisplayAlerts = False
    5.     For Each sht In ThisWorkbook.Sheets
    6.             Set wk = Workbooks.Add
    7.             k = k + 1
    8.             Workbooks(1).Sheets(k).Copy Workbooks(2).Sheets(1)
    9.             ss = ThisWorkbook.path & "\" & sht.Name & ".xlsx"
    10.             wk.SaveAs ss
    11.             wk.Close
    12.     Next
    13. Application.DisplayAlerts = True
    14. MsgBox "拆分工作簿完成！"
    15. End Sub

    获取文件夹下的文件名称

    Excel VBA语法与应用手册
    pdf 0星 超过10%的资源 96.59MB
    下载
    1. Public Sub 获取文件夹下的文件名称()
    2. Dim mypath, myfile, path
    3. Dim arr()
    4. Dim i As Integer
    5. 'On Error Resume Next
    6. mypath = "C:\Users\Administrator\Desktop\汇总\汇总\" 'ThisWorkbook.path + "\汇总\"
    7. myfile = Dir(mypath, vbDirectory)
    8. Do While myfile <> ""
    9.     If myfile <> "." And myfile <> ".." Then
    10.         path = mypath + myfile
    11.         i = i + 1
    12.         ReDim Preserve arr(1 To 1)
    13.         arr(i) = myfile
    14.          ThisWorkbook.Sheets("测试").Cells(1, "C").Resize(UBound(arr), 1) = Application.Transpose(arr)
    15.          Debug.Print arr(0)
    16.         myfile = Dir
    17.     Else
    18.         myfile = Dir
    19.     End If
    20. Loop
    21. End Sub

    合并目录所有工作簿全部工作表

    1. Sub 合并目录所有工作簿全部工作表()
    2. On Error Resume Next
    3. Dim MP, MN, AW, Wbn, wn
    4. Dim Wb As Workbook
    5. Dim i, a, b, d, c, e, last_row, ni
    6. Application.ScreenUpdating = False
    7. Application.DisplayAlerts = False
    8. '--初始化
    9. Workbooks("台账自检.xlsm").Sheets("热联").Delete
    10. Workbooks("台账自检.xlsm").Sheets("明细").Delete
    11. Workbooks("台账自检.xlsm").Sheets("汇总").Range("A:M") = ""
    12. '--
    13. MP = ActiveWorkbook.path '工作簿路径
    14. 'MP = "C:\Users\HONORS\Desktop\结算小组数据检查" '工作簿路径
    15. MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
    16. 'Set Newbook = Workbooks.Add
    17. AW = ActiveWorkbook.Name
    18. Num = 0
    19. ni = 0
    20. e = 3 '标题栏数量
    21. Do While MN <> ""
    22.     If MN <> AW And MN <> MP & "台账自检.xlsm" Then '"C:\Users\HONORS\Desktop\结算小组数据检查\台账自检.xlsm"
    23.     Debug.Print MN
    24.     ni = ni + 1 '判断导入表的顺序
    25.     Debug.Print "导入第" & ni & "表"
    26.     Set Wb = Workbooks.Open(MP & "\" & MN)
    27.     a = a + 1
    28.     '工作簿判断
    29. '    Newbook.Sheets.Add After:=Newbook.Sheets(Newbook.Sheets.Count) '新建工作表
    30. '    Newbook.Sheets.Add.Name = Wb.ActiveSheet.Name
    31.     Workbooks("台账自检.xlsm").Sheets.Add.Name = Wb.ActiveSheet.Name
    32. '   With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")
    33.   With Workbooks("台账自检.xlsm").ActiveSheet
    34. '   With Newbook.ActiveSheet
    35.                 d = Wb.ActiveSheet.UsedRange.Columns.Count '判断列数
    36.                 c = Wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数
    37.                 Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & c
    38.                 last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置
    39.                 Debug.Print "终表最后一行" & last_row
    40.                 Wb.ActiveSheet.Range("a1:BP" & c).Copy .Cells(last_row + 1, 1) '复制数据
    41.                 wn = Wb.ActiveSheet.Name
    42.                 .Cells(4, "Z") = "表名"
    43.                 .Cells(e + 1, "Z").Resize(c - 2, 1) = MN & wn
    44.                 e = e + c '累计行数
    45.                 .Range("A:L").RowHeight = 12 '行高
    46.                 .Range("A:L").ColumnWidth = 10 '列宽
    47.         Wbn = Wbn & Chr(13) & Wb.Name
    48.         Wb.Close False '关闭工作簿
    49.     End With
    50. End If
    51. MN = Dir
    52. Loop
    53. '--
    54. 'Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"
    55. '复制数据
    56. With Workbooks("台账自检.xlsm").Sheets("汇总")
    57. '运输台账复制
    58. Workbooks("台账自检.xlsm").Sheets("热联").Range("C:C").Copy .Cells(1, "A")
    59. Workbooks("台账自检.xlsm").Sheets("热联").Range("D:D").Copy .Cells(1, "B")
    60. Workbooks("台账自检.xlsm").Sheets("热联").Range("H:H").Copy .Cells(1, "C")
    61. Workbooks("台账自检.xlsm").Sheets("热联").Range("o:o").Copy .Cells(1, "D")
    62. Workbooks("台账自检.xlsm").Sheets("热联").Range("p:p").Copy .Cells(1, "E")
    63. '工程台账复制
    64. Workbooks("台账自检.xlsm").Sheets("明细").Range("A:A").Copy .Cells(1, "h") '计划号
    65. Workbooks("台账自检.xlsm").Sheets("明细").Range("h:h").Copy .Cells(1, "i") '计划号
    66. Workbooks("台账自检.xlsm").Sheets("明细").Range("i:i").Copy .Cells(1, "j") '计划号
    67. Workbooks("台账自检.xlsm").Sheets("明细").Range("j:j").Copy .Cells(1, "k") '计划号
    68. Workbooks("台账自检.xlsm").Sheets("明细").Range("l:l").Copy .Cells(1, "k") '车牌号
    69. .Cells(2, "L").Value = "匹配"
    70. c = .Cells(Rows.Count, "j").End(xlUp).Row
    71. .Cells(3, "L").Resize(c, 1) = "=VLOOKUP(J3,A:E,3,FALSE)"
    72.      .Range("A:L").RowHeight = 12 '行高
    73.     .Range("A:L").ColumnWidth = 12 '列宽
    74.     .Range("A:L").Font.Size = 8 '字号
    75.     .Range("A:L").Font.Name = "微软雅黑" '字体
    76. End With
    77. Workbooks("台账自检.xlsm").Sheets("汇总").Activate
    78. Workbooks("台账自检.xlsm").Save
    79. Range("a1").Select
    80. Application.ScreenUpdating = True
    81. Application.DisplayAlerts = True
    82. MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
    83. End Sub

    新建文件夹

    1. Public Sub 新建文件夹()
    2. Dim spatch
    3. Dim newmd, t
    4. Dim i
    5. spatch = "C:\Users\Administrator\Desktop\汇总" 'Excel.ThisWorkbook.path
    6. newmd = spatch & "\" & ActiveSheet.Name
    7. t = Dir(newmd, vbDirectory)
    8. If t = "" Then
    9. i = MsgBox("文件夹不存在是否创建并写入？", vbYesNo + vbQuestion, "存盘提示")
    10. Else
    11. i = MsgBox("文件夹已存在", vbOKOnly, "存盘提示")
    12. Exit Sub
    13. End If
    14. If i = 6 Then mkdir newmd Else Exit Sub
    15. End Sub

    字典和数组使用

    1. Public Sub 字典和数组()
    2. '数组的使用
    3. 'Dim arr(1 To 4)
    4. 'Dim rng
    5. 'Dim n
    6. 'For Each rng In Sheets("测试").[a1:a3]
    7. '    n = n + 1
    8. '    arr(n) = rng
    9. 'Next
    10. 'Dim arr
    11. 'arr = Application.Transpose(Sheets("测试").[a1:a3])
    12. 'Sheets("测试").Range("d2:d" & UBound(arr)) = arr
    13. 'Sheets ("测试")
    14. '=========字典使用
    15. Dim d As New Dictionary
    16. Dim j, k
    17. Set d = CreateObject("scripting.dictionary")
    18. d.Add "张三", "123"
    19. d.Add "李四", "345"
    20. j = d.Keys
    21. 'Debug.Print  'Application.Index(d.Keys, 2) 'd.Keys(0)
    22. 'Debug.Print d("李四") 'Application.Index(d.Items, 2) 'd.Items(1)
    23. '------exist,remove ,remove all 方法
    24. 'd.Remove ("李四")
    25. d.RemoveAll
    26. 'Debug.Print d.Exists("李四")
    27. 'd.Key("李四") = "王五"
    28. 'd.Item("王五") = "789"
    29. 'k = d.Items
    30. 'Debug.Print d.Item("王五") 'd.Count
    31. '字典写入
    32. Dim arr, arr1
    33. Dim rng, rngs
    34. arr = Sheets("测试").Range("a1:a" & Sheets("测试").Cells(Rows.Count, "a").End(xlUp).Row)
    35. For Each rng In arr
    36. '    arr1 = VBA.Split(rng, "|")
    37.     For Each rngs In arr
    38.         d(rngs) = ""
    39.     Next
    40. '    i = VBA.Join(d.Keys, "|")
    41. '    n = n + 1
    42. '    Sheet2.Cells(n, "a") = i
    43. '    d.RemoveAll
    44. Next
    45. Sheets("测试").[f2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
    46. End Sub

    判断工作表是否存在并新建

    1. Public Sub 新建工作表()
    2. On Error Resume Next
    3. Dim sh
    4. Dim sname
    5. Dim ws
    6. Application.DisplayAlerts = False
    7. Application.ScreenUpdating = False
    8.     sname = "测试"
    9. '            Debug.Print ws
    10.             If ThisWorkbook.Worksheets(sname) Is Nothing Then
    11.                  '新建工作表
    12.                   ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
    13.                   ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count).Name = sname
    14.               '复制数据
    15.                     ThisWorkbook.Sheets("记录").Range("A:T").Copy 'UsedRange.Copy
    16.                     ThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据
    17.                     ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高
    18.             Else
    19.                     ThisWorkbook.Worksheets(sname).Delete
    20. '                    MsgBox "新增错误，表名已存在", vbOKOnly, "提示"
    21. '                    Exit Sub
    22.             End If
    23. Application.DisplayAlerts = True
    24. Application.ScreenUpdating = True
    25. End Sub

    批量获取区域

    1. Public Sub 批量获取区域()
    2. Dim k%
    3. Dim lr
    4. Dim di, di1
    5. Dim i
    6. Dim rngs, rng
    7. Dim ad, ads
    8. Dim d As New Dictionary
    9. 'On Error Resume Next
    10. Set d = CreateObject("scripting.dictionary")
    11. With Sheets("测试")
    12.             lr = .Cells(Rows.Count, "G").End(xlUp).Row '获取最后一行
    13.             Set rngs = .Range("G1:G" & lr) '确认列
    14.             For Each rng In rngs
    15.                     If rng.Value Like "1" Then
    16. '                    Debug.Print rng.Row
    17.                     ad = rng.EntireRow.Range("a1:EQ1").Value
    18.                     d(rng.Row) = ad
    19. '                    Set ads = Union(ad, ads)
    20.                     di = Application.Transpose(Application.Transpose(Application.Transpose(d.Items)))
    21.                     End If
    22.             Next
    23. '            Debug.Print UBound(di, 2)'二维数组列数
    24.             For i = 1 To d.Count
    25.              Sheets("测试").Range("a" & i).Resize(, UBound(di, 2)) = Application.Index(di, i)
    26.             Next i
    27.  
    28. End With
    29. '区域合并，整体合并
    30. End Sub

  • 相关阅读:
    鸿蒙原生App开发之：套用混合app开发思路
    产品经理工作流程
    老子云平台会员专业又有性价比！
    [软件工具]ARW文件批量转图片jpg工具使用教程
    单语言/多语言仿百度百科网站源码开发 第四篇
    文心一言 vs GPT-4 —— 全面横向比较
    【大模型的一些基本结论】
    本地MQTT服务器搭建（EMQX）
    Nginx之正则表达式、location匹配简介及rewrite重写
    vuex.esm.js?e4c8:1134 [vuex] module namespace not found in mapMutations():
  • 原文地址：https://blog.csdn.net/u010719791/article/details/126111362