精华内容
下载资源
问答
  • 虽说现在VBA真的是毫无排面,但只要会启用「宏」,收藏几个复制粘贴就能用的代码,作为一办公室民工,总有用得上的时候。所以这里记录几个之前工作中高频使用的小小小脚本。下面提到的工作簿,即单个的 .xlsx 或 ....

    d5e13d8a75a73ff49169d9f80cc042e6.png

    虽说现在VBA真的是毫无排面,但只要会启用「宏」,收藏几个复制粘贴就能用的代码,作为一名办公室民工,总有用得上的时候。

    所以这里记录几个之前工作中高频使用的小小小脚本。

    下面提到的工作簿,即单个的 .xlsx.xls 文件,工作表就是文件里的 sheet

    1、自定义函数

    自定义一个 Countcolor() 函数,统计区域内指定颜色的单元格个数。

    无情,知乎的代码块提供了几十种语言,就是没有VB……

    Function Countcolor(arr As Range, c As Range)
        Dim rng As Range
        For Each rng In arr
            If rng.Interior.Color = c.Interior.Color Then
                Countcolor = Countcolor + 1
            End If
        Next rng
    End Function

    函数说明:

    比如在单元格输入 =countcolor(B2:F16,B8),会返回区域 (B2:F16) 内与 B8 单元格颜色相同的单元格数。

    eeba4e108787e40bd621df1c7a187e4c.png

    2、合并工作簿

    依次打开某个文件夹下的 EXCEl 工作簿,将每一个工作簿下所有 Sheets 复制到当前的工作簿中。

    d5c49d3d13778b611ba7d534631ddfd9.png
    Sub BooksMerge()
        Dim FileOpen
        Dim X As Integer
        Application.ScreenUpdating = False
    
        FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft_Excel文件(*.xls*),*.xls*", MultiSelect:=True, Title:="合并工作薄")
        X = 1
        While X <= UBound(FileOpen)      ' UBound():返回数组最大下标
            Workbooks.Open Filename:=FileOpen(X)
            Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        X = X + 1
        Wend
    ExitHandler:
        Application.ScreenUpdating = True
        Exit Sub
    errhadler:
        MsgBox Err.Description
    End Sub

    3、合并工作表

    新建一个空白的 sheet,把工作簿下所有 Sheet 里的数据按顺序逐行复制到这个新建的空白表格中。

    比如2019年上证指数的行情数据,按季度分在了4张工作表里,这里希望把它们合在一个表格里:

    530a4d2b271bf3493ed94cbe43ce5d4c.png

    复制以下代码:

    Sub SheetsMerge()
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Dim sheets_pre As Integer, sheets_aft As Integer
    
        sheets_pre = Sheets.Count
    
        '删除空白的的工作表,如无必要,这步可省略
        Dim sht As Worksheet
        For Each sht In Worksheets
            If sht.Cells.Find(What:="1") Is Nothing And sht.Name <> "0" Then
                sht.Delete
            End If
        Next
    
        '在第一位新建一个空白汇总表表名"2019年汇总"
        ThisWorkbook.Sheets.Add Before:=Worksheets(1)
        ActiveSheet.Name = "2019年汇总"
        
        '把第一张表包括表头(第一行)复制到汇总表
        For i = 1 To Sheets(2).Range("A65536").End(xlUp).Row
            Sheets(2).Rows(i).Copy Rows(i)
        Next
        
        '把后面的表去掉表头后复制到汇总表
        For j = 3 To Sheets.Count
            If Sheets(j).Name <> ActiveSheet.Name Then
                Y = Sheets(j).Range("A65536").End(xlUp).Row
                X = Range("A65536").End(xlUp).Row
                For i = 1 To Y
                    Sheets(j).Rows(i + 1).Copy Rows(X + i)
                Next
            End If
        Next
        
        Range("B1").Select
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        sheets_aft = Sheets.Count - 1
        
        '完成后弹出窗口提示
        MsgBox "当前工作簿下的全部工作表已经合并完毕!" & vbCrLf & _
               "共有" & sheets_pre & "张表," & "合并了" & sheets_aft & "张。"
    End Sub

    保存后,执行「宏」,效果应该是这样的:

    a170b6d161e3fa21812f19f9ba3e1634.png

    4、分组后拆分到工作表

    把一个表格里的数据,按某一列分组,每一组的数据复制到一张新的工作表中。

    比如:继续前面的2019年上证指数行情数据,在第一列新增「月份」字段,现在希望每个月的行情数据单独放在一张 Sheet 里。

    ae520e122b3b197eb04f69858cf196fa.png

    复制以下代码:

    Sub Sheetsplit()
    
        Dim arr, rngHead As Range, rngTotal As Range, d As Object, _
        k, t, r&, i&, lr&, lc%, sh As Worksheet
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        arr = Range("a1").CurrentRegion
        lr = UBound(arr)
        lc = UBound(arr, 2)
        
        Set rngHead = Rows(1)
        Set rngTotal = Rows(lr)
        Set d = CreateObject("scripting.dictionary")
        
        For i = 2 To lr - 1
            If Not d.Exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(, lc)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(, lc))
            End If
        Next
        
        k = d.Keys
        t = d.Items
        
        With Sheets
            For i = 0 To d.Count - 1
                With .Add(After:=.Item(.Count))
                    .Name = k(i)
                    rngHead.Copy .[a1]
                    .Cells(1, 1).Resize(, lc).Columns.AutoFit
                    t(i).Copy .[a2]
                End With
            Next
        End With
        
        Sheets(1).Activate
        
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub

    保存后,执行「宏」,效果应该是这样的:

    0ff6a904fc1c8624335cb4b0539ba1f3.png

    5、工作表保存为工作簿

    EXCEL 文件里每一张 Sheet 单独保存为一个工作簿。

    比如:继续使用前面的行情数据,把每个月的行情保存为单独的一个 EXCEL 文件。

    复制以下代码:

    Sub Booksplit()
    
       Application.ScreenUpdating = False
       
       Dim folder As String
       folder = ThisWorkbook.Path & "" & "Index"
       
       If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
       
       Dim sht As Worksheet
       For Each sht In Worksheets
           If sht.Name <> "" Then
               sht.Copy
               ActiveWorkbook.SaveAs folder & "" & sht.Name
               ActiveWorkbook.Close
           End If
       Next
       
       Application.ScreenUpdating = True
       
    End Sub

    保存后,执行「宏」,我们在同样的文件路径下会发现一个新的文件夹「Index」:

    679f8f75b8334f144d28ce69edfd9e03.png

    打完,收工。

    展开全文
  • 我有一个加工费索赔表,是电子表格的,里面有很多个子表。...print(dic) 这个运行结果居然要20多秒(也就是40多个产品,40张子表,每个产品子表也就是30行数据),用VBA大概就是1秒左右。请问高手究竟什么情况

    4591a45f9ae7994fbd0ba58c5f1b5926.png

    d248984a42b900de39a64da3b5876484.png

    我有一个加工费索赔表,是电子表格的,里面有很多个子表。

    每个子表存放一款产品的加工工序和对应成本,子表的名字也以产品编号作为名字。其中每个子表的第二列(也就是B列)是存放工序的,但是要搜索工序这个关键字才知道工序是从哪行开始,具体如下:

    from win32com.client import Dispatch
    xlapp=Dispatch("excel.application")
    wb=xlapp.workbooks("2020年公司加工费索赔表(正式版)")
    dic={}#建立一个字典,用来保存对应产品的加工费清单
    for sheet in wb.worksheets:
    if sheet.name!="物料清单总览": #物料清单总览没有保存有我需要的加工费信息,不需要参与统计
    if sheet.name not in dic: #判断该子表的名称(也就是物料编号)是否已经存在字典里
    dic[sheet.name]={}#在字典里面插入关键字(物料编号),并绑定一个新的子字典,用来存放该物料号下各个工序(工序名称作为子字典的关键字),以及工序对应的价格
    ubound=sheet.cells.find("工序").row#查找工序开始的具体行数(列数已经知道是第二列)
    lbound=sheet.usedrange.rows.count#判定工序终止的行数
    for i in range(ubound+1,lbound):#用循环从工序开始的行数,一直到终止的行数
    dic[sheet.name][sheet.cells(i,2).value]=sheet.cells(i,7).value#在子字典(产品编号)里面插入工序作为关键字,对应的第七列的同行数据就是工序对应的加工费
    print(dic)

    这个运行结果居然要20多秒(也就是40多个产品,40张子表,每个产品子表也就是30行数据),用VBA大概就是1秒左右。请问高手究竟什么情况

    展开全文
  • 先写一个公用的方法,只需要传入各系统的连接字符串,与SHEET名 代码注释很详细 需注意的是,时间字符串 需要用Format(X, "yyyy-mm-dd HH:MM") 进行转换,否则会显示为数值 Private Sub GetData(strCn As String...

    因每隔一段时间,需要提供各系统的有效用户信息,于是写了简单的获取显示  记录一下

    先写一个公用的方法,只需要传入各系统的连接字符串,与SHEET名

    代码注释很详细

    需注意的是,时间字符串 需要用Format(X, "yyyy-mm-dd HH:MM") 进行转换,否则会显示为数值

    Private Sub GetData(strCn As String, shtname As String)
    
    Dim cn As Object    '定义数据链接对象 ,保存连接数据库信息
    
    Dim rs As Object    '定义记录集对象,保存数据表
    
    Set cn = CreateObject("ADODB.Connection")  '创建数据链接对象
    
    Set rs = CreateObject("ADODB.RecordSet")  '创建记录集对象,用于接收数据查询获得的结果集
    
    Dim strSQL As String '字符串变量
    
    
    strSQL = "select a.user_id,a.user_name,a.email_address,a.login_time,a.crtdt from user a where a.user_status in ('A','L')"    '设置SQL语句
    
    
    cn.Open strCn '打开连接
    
    rs.Open strSQL, cn '读取数据库中的数据
    
    
    Dim i As Integer, j As Integer, h As Integer, g As Integer, sht As Worksheet 'i,j,h为整数变量;sht 为excel工作表对象变量,指向某一工作表
    
    i = 2
    
    
    
    If Issheet(shtname) Then
      Set sht = ThisWorkbook.Worksheets(shtname)  '存在则获取对应sheet'
    Else
      Set sht = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)) '不存在则创建新的sheet'
        sht.name = shtname  '给新建的sheet命名'
    End If
    
    
    
    'sht.Range(sht.Cells(2, 1), sht.Cells(sht.UsedRange.Rows.Count, sht.UsedRange.Columns.Count)).ClearContents  '清除除第一行以外的数据
    
    sht.Cells.ClearContents  '清除sheet里的 所有数据
    
    
    For h = 2 To rs.Fields.Count + 1
    
        sht.Cells(1, h).Value = rs.Fields(h - 2).name '将字段写入sheet的第一行
    
    Next
    
    h = 1
    
    Dim str As String
    
    
    
    '循环读取数据并将数据显示到excel中
    
    Do While Not rs.EOF     '当数据指针未移到记录集末尾时,循环下列操作
    
        sht.Cells(i, 1).Value = h    '把当前记录的字段1的值保存到sheet1工作表的第i行第1列
        
        For g = 2 To rs.Fields.Count + 1
          
         If IsDate(rs(g - 2)) = True Then
            sht.Cells(i, g).Value = Format(rs(g - 2), "yyyy-mm-dd HH:MM") '如果是时间格式 需要Format转换一下  否则会显示数值
         Else
            sht.Cells(i, g).Value = rs(g - 2) '将字段写入sheet的第一行
         End If
    
        Next
    
        rs.MoveNext                      '把指针移向下一条记录
    
        i = i + 1                        'i加1,准备把下一记录相关字段的值保存到工作表的下一行
        h = h + 1
    
    Loop                                 '循环
    
    rs.Close   '关闭记录集,至此,程序将把某数据表的字段1和字段2保存在excel工作表sheet1的第1、2列,行数等于数据表的记录数
    
    cn.Close
    End Sub

    还有公用的 获取单元格列标的字母  与  SHEET是否存在

    Function getColumnLetter(ByVal myCol As Integer) As String '获取单元格列标的字母
    Dim columnName As String
     Dim k As Integer
     k = (myCol - 1) \ 26
     Select Case k
     Case 0
     Case Else
     columnName = columnName & Chr(64 + k)
     End Select
     columnName = columnName & Chr(64 + ((myCol - 1) Mod 26) + 1)
     getColumnLetter = columnName
    End Function
    
    Function Issheet(ByVal name As String) As Boolean '判断sheet是否存在'
     Dim i, n As Integer, bool As Boolean
     bool = False
     n = ThisWorkbook.Sheets.Count
     For i = 1 To n
     If ThisWorkbook.Worksheets(i).name = name Then
        bool = True
     End If
     Next i
     
     Issheet = bool
    End Function

    最后,连接字符串格式

    str = "Provider = MSDAORA;Password=xxxx;User ID=xxxx;Data Source=xxx;Persist Security Info=True;" 

    展开全文
  • 今天项目上有个应用,获取指定Excel文件下的所有sheet的名称以及当前sheet中指定单元格的值,并把他们写到固定的sheet中去,看了下,文件比较多,而且每个文件sheet的个数比较多,也不一样,所以打算写个程序来帮...

    今天项目上有个应用,获取指定Excel文件下的所有sheet的名称以及当前sheet中指定单元格的值,并把他们写到固定的sheet中去,看了下,文件比较多,而且每个文件sheet的个数比较多,也不一样,所以打算写个程序来帮我们实现任务,代码很简单,也写的比较死板。欢迎大家给出意见及你的代码:

    Sub aaaa()
    Dim sh1, sh2 As Worksheet
    Dim shName, cellValue As String
    'On Error Resume Next
    
    Set sh1 = Workbooks(1).Sheets(1)
    'Workbooks.Open Filename:="D:\_jack\Finance Report\Report Layout\TA Opex Report 2014.xlsx"
    Workbooks.Open Filename:="D:\_jack\Finance Report\Report Layout\Rolling PL Template v1 (2).xlsx"
    
    For i = 1 To Workbooks(2).Worksheets.Count
        Workbooks(2).Activate
        Set sh2 = ActiveWorkbook.Worksheets(i)
        sh2.Activate
        n = sh2.Name
        'v = sh2.Cells(5, 7).Value  'G5单元格
        v = sh2.Cells(4, 3).Value  'C4单元格
        
        Workbooks(1).Activate
        sh1.Activate
        sh1.Cells(i, 1) = n
        sh1.Cells(i, 2) = v
        
    Next
    Workbooks(2).Close
    End Sub
      


    版权:以上代码由本人开发,版权归 http://www.cnblogs.com/mq0036 个人所有。若用于非商业目的,您可以自由转载,转载请注明出处。

    转载于:https://www.cnblogs.com/mq0036/p/4195836.html

    展开全文
  • 今天项目上有个应用,获取指定Excel文件下的所有sheet的名称以及当前sheet中指定单元格的值,并把他们写到固定的sheet中去,看了下,文件比较多,而且每个文件sheet的个数比较多,也不一样,所以打算写个程序来帮...
  • 获取当前sheet列表 Sub GetSheetList() Dim sht As Object '//... Dim s As String '// 追加sheet名 Dim i As Long '// loop count '// 追加sheet Call Sheets.Add(After:=Sheets(Sheets.Count)) s = "AddSheet
  • 一个Excel表,每隔几天有一个汇率数据单独在一个sheet上,一共有...现在的思路就是:把每一个sheet中汇率单元格数据和sheet名取到然后复制到一张新的sheet里,循环一直把所有的sheet循环一遍就可。在VBA环境执行成功。
  • 从单元格获取数据获取sheet名字为 “sheetname”的表格中的第一行第五列的值 赋值给变量aa = Sheets("sheetname").Cells(1, 5).value修改单元格数据修改sheet名字为 “sheetname”的表格中的第一行第五列...
  • Excel如何自动生成有超链接的Sheet目录?...✔这里我先不给出答案,我给出我来做这个思路:我想到要做目录,首先要对所有的Sheet进行循环遍历,获取Sheet的名字,然后在目录表中列出来每个Sheet的名字,并...
  • VBA踩坑记录

    2021-01-08 09:21:07
    2.动态添加事件方法 参数需要sheet页ID,不能用sheet名定位,只能用组件数+1获取。 3.涉及增删sheet的时候,慎用activesheet。 4.动态填充数据,仅有1行数据时 用End获取行尾列尾需要特殊处理。 PS:自由的东西 更...
  • VBA编程之ODBC连接数据库

    千次阅读 2020-07-25 16:24:18
    下面的例子展示了在VBA中使用ODBC连接数据库并获取数据,填充工作表内容。 使用前要先在sheet名字上点右键,选择查看代码,进入VBA编辑模式: 第一次用的时候要在VBA编辑窗口点击工具–引用,勾选:Microsoft ...
  • 1.上期我们聊了SQL常用查询语句中的字段查询,其简化版语法如下:SELECT 字段 FROM 表名当时我们说,FROM关键词指明了要获取字段信息的表的名称。倘若数据源是Excel表格,则需要在表名后增加美元符号$,并用中括号...
  • 主要功能包含:一是VBA连接SQL Server数据库查询的功能,二是根据自动获取的日期动态将结果数据导出为多个Excel文档的功能。导出的文件命名为按机构编码和日期动态命名方法,格式:机构编码+主文件+日期,生成的...
  • 获取当前sheet的名字 Public sName sName = ActivateSheet.Name 2.选中单元格:  Worksheets(sName).Range(strRange).Select 3.插入行:(插入列类似) Selection..EntireRow.Insert ...
  • If aimSheetName = BKJ01 Or BKJ02 Or BKJ03 Then '当sheet名为这3个的时候 aimBook.Sheets(i).Cells(rowCount, 1) = "公司负责人: 主管会计工作负责人: 会计机构负责人: 会计主管: 复核人: 制表人:" ElseIf ...
  • 项目作业中需要造数据,从txt文件中获取定长数据,直接从txt中修改,会显得十分麻烦,于是便利用excel自带的vba写了一个小工具。效果如下: A1表示字段,A2表示长度,A3是数据,也可以增加字段类型,自行拓展 ...
  • 中文版Excel.2007图表宝典 1/2

    热门讨论 2012-04-06 18:49:24
    除此之外,还可以学习如何通过AutoShapes,用图片和色彩修饰图表,以及利用VBA编程创建交互式的动态图表。 目录 -------------------------------------------------------------------------------- 第Ⅰ部分 基础...
  • 中文版Excel.2007图表宝典 2/2

    热门讨论 2012-04-06 19:01:36
    除此之外,还可以学习如何通过AutoShapes,用图片和色彩修饰图表,以及利用VBA编程创建交互式的动态图表。 目录 -------------------------------------------------------------------------------- 第Ⅰ部分 基础...
  • “店铺”和指定“颜色”的内容(sheet1有“店铺”、“数量”、“颜色”等字段及若干数据)。 操作前请先确定是否安装有MS Query。附上举例文件,请解压到D盘根目录下: 销售.xls为源数据,查询.xls中设置了msquery...
  • Excel百宝箱8.0

    2011-06-07 21:32:17
    【生成系统图标】【获取内置命令】【修复Excel】【破解VBA密码】【删除空单元格】【转置选区】【按列倒置】【按列倒置】【字母大小写转换】【小写金额转大写】【大写金额转小写】【区域数据加密】【多区域复制】【按...
  • EXCEL百宝箱8.0终极版

    2011-11-05 16:48:02
    获取内置命令ID】:VBA编程人员常用的工具。可以查询Excel内部命令的ID号 【修复Excel】:当您的Excel某些功能无法使用时,或者无缘无故多出很多菜单、工具栏时,本工具可以瞬间恢复Excel到默认状态 【破解VBA密码...
  • 获取内置命令ID】VBA编程人员常用的工具。可以查询Excel内部命令的ID号 【按颜色筛选】让Excel 2003也可以按背景色筛选数据,2007或者2010用户不需要使用 【按颜色排序】让Excel 2003也可以按背景色筛选排序,2007...

空空如也

空空如也

1 2
收藏数 24
精华内容 9
关键字:

vba获取sheet名