我们致力于为大家奉献最有效的经验，让大家能够解决掉问题，但是大家也都知道，每个人遇到的情况都是不一样的，大家在看经验的同时，除了跟随操作，也需要自己的思考，举一反三的解决问题，这样才会变得更加有内涵，一起成长为一样的经验达人。根据二八定律，学好这excel VBA，就能完成80%的工作。

在实际操作中，经常需要复制指定的单元格区域到另外一个单元格区域。要复制指定单元格区域到其他位置，使用Range对象的Copy方法，如下面的代码所示。

#001 Sub RangeCopy()

#002 Application.DisplayAlerts = False

#003 Sheet1.Range("A1").CurrentRegion.Copy Sheet2.Range("A1")

#004 Application.DisplayAlerts = True

#005 End Sub

代码解析：

RangeCopy过程将如图 所示的Sheet1工作表中A1单元格的当前区域复制到Sheet2工作表中以A1单元格为左上角单元格的区域，如图 2所示。

图 1 需复制的数据表

图 12 复制结果

Range对象的Copy方法的语法如下：

Copy(Destination)

参数Destination表示复制单元格区域的目标区域，如果省略该参数，Excel将把该区域复制到剪贴板中。

使用Copy方法复制单元格区域时，也复制了该单元格区域的格式，如图 12所示。

复制单元格区域时，如果目标区域为非空单元格区域，Excel将显示如图 13所示的消息框提示是否替换单元格内容，可以设置Application.DisplayAlerts属性值为False，使复制时不出现该消息框。

图 73 替换对话框

第2行代码通常复制单元格区域的操作不会将单元格区域的列宽大小同时复制，如图 72所示。如果希望在复制单元格区域的同时，也复制源区域的列宽大小，可以使用下面的代码。

#001 Sub CopyWithSameColumnWidths()

#002 Sheet1.Range("A1").CurrentRegion.Copy

#003 With Sheet3.Range("A1")

#004 .PasteSpecial xlPasteColumnWidths

#005 .PasteSpecial xlPasteAll

#006 End With

#007 Application.CutCopyMode = False

#008 End Sub

代码解析：

第4行代码使用Range对象的PasteSpecial方法选择性粘贴剪贴板中的Range对象的列宽。

第5行代码粘贴剪贴板中的Range对象全部内容。

第7行代码取消应用程序复制模式。

应用于Range对象的PasteSpecial方法将剪贴板中的Range对象粘贴到指定区域，在粘贴时可以有选择的粘贴对象的部分属性。其语法如下：

PasteSpecial(Paste, Operation, SkipBlanks, Transpose)

参数Paste指定要粘贴的区域部分，可为表格 71所列的XlPasteType常量之一。

表格 71 XlPasteType 常量

参数Operation指定粘贴操作。可为表格 12所列的XlPasteSpecialOperation常量之一。

表格 12 XlPasteSpecialOperation常量

参数SkipBlanks指示是否跳过空单元格，若参数值为True，则不将剪贴板上区域中的空白单元格粘贴到目标区域中。默认值为False。

参数Transpose指示是否进行转置，若参数值为True，则粘贴区域时转置行和列。默认值为False。

运行CopyWithSameColumnWidths过程后，Sheet3工作表如图 74所示，目标区域的各列列宽与源区域一致。

图 74 粘贴列宽后的复制结果

注意 使用PasteSpecial方法时指定xlPasteAll(粘贴全部)，不会粘贴列宽。

如果你在工作中还需要设计其他的表格模板，都可以留言，我们会根据大家需求来整理相关的学习资料，目的只有一个，那就是学好Excel，提高工作效率！

今日也是应读者的需求利用VBA解决实际问题。学而不用则殆！学习了新的知识就是要不断的利用，提升，再利用再提升。所以要给这位提问题的朋友点赞！

有的读者问：如何利用VBA来解决Excel提示不同的单元格格式太多的问题呢？

首先，我们先分析一下这个情况是什么时候发生，一般有几种情况会发生这类问题。

1复制粘贴时，这时会提示单元格格式太多，无法粘贴，而且要经过长时间的不知在做什么的处理过程，然后，EXCEL崩溃。你只能重启。

2在移动工作表时，将工作表整体从一个文件转移到另一个工作表时，也会出现这个问题，现象和上述一样。

3 在筛选数据时，有时候，在筛选一个值时，往往会出现上述的提示，当你按确认键后，EXCEL会再次计算，好在不会崩溃，只是时间非常长，这种情况往往出现在这个工作表的数据量巨大，往往是1万行以上的数据。

然后，我们分析一下上述问题产生的原因。其实这类问题的产生不是用户的错，而是OFFICE系统，或者说，EXCEL从03版升级到07版之后，带给用户的 一个遗留问题，他们潇洒的升级完了，但留下了一堆苦果让用户去慢慢品尝。为什么这么说呢？一点也不过分！03版和07版不兼容就是罪魁祸首。在07版加入了很多全新的内容，这些在03版及低版本无法显示，才出现了上述的问题。

所以，当你用07版本打开03版本；或者03版打开07版本（有兼容包）；或者是往03版本拷贝07版本数据；或者是往07版本拷贝入03版本数据时，极易发生上述问题。如果一个工作表的数据既有03版本的又有07版本的，那么你非常的不走运，在你筛选时，很可能就是这个苦果。

问题的原因分析完了，那么怎么解决呢？

办法一：在工作表中刷格式，采用一个格式全部的刷一遍，但也不能很好的解决问题。

办法二：新建一个工作表，把原数据数值粘贴到新的工作表中，原来的格式全然没有了。

办法三：就是今天我们重点讲的VBA方法：

拷入下面的代码：

Sub KK()

2 Dim s As Style

3 Application.ScreenUpdating = False

4 On Error Resume Next

5 For Each s In ThisWorkbook.Styles

6 If Not s.BuiltIn Then s.Delete

7 Next

8 Application.ScreenUpdating = True

9 MsgBox ("OK")

10 End Sub

很简单的几行代码，往往能解决很大的问题。代码讲解：

（1）Application.ScreenUpdating = False

Application.ScreenUpdating = True

上述语句是成对出现的，前者是关闭屏幕更新，以提高程序的效率；后者是打开屏幕刷新，

（2）On Error Resume Next

忽略错误，继续执行

（3）第五行和第七行构成了一个FOR NEXT语句，此语句在之前的文章中讲过，不过这里用的是For Each s In ThisWorkbook.Styles,翻译过来就是说对于这个工作表中所有的格式将进行的操作，什么操作呢？就是：

If Not s.BuiltIn Then s.Delete 执行到这里，所有的自定义格式全部被删除掉了。

（4）最后全部执行完成弹出对话框：MsgBox ("OK")

看我们的代码截图：

剩余的工作就是，画个按钮，连锁上述代码，就可以了，经测试，这个方法还是可行的，如有遇到这个问题的读者可以试试看啊。

今日技巧提示：

1 Application.ScreenUpdating = False；Application.ScreenUpdating = True

的作用是什么？能否单独出现？

2. On Error Resume Next 作用是什么？

3，For each next 语句是否理解呢？

分享成果，随喜正能量

今天将继续给大家分享VBA中的一些常用语句，今天主要讲解些工作薄语句相关的一些常见的语句，对于工作薄，相信大家不很陌生，工作簿是在Excel中，用于保存数据信息的文件。在一个工作簿中，可以有多个不同类型的工作表，默认情况下包含3个工作表，最多可达到255个工作表。可以说，Excel文档就是工作簿，它为用户提供了一个计算操作环境。工作簿不仅提供了完整的计算功能，还结合了许多应用数据处理的功能，如数据筛选、图表制作、统计分析等，在各行各业都有广泛应用。

今日的讲解主要集中在工作薄相关操作，希望朋友要仔细的理解掌握，对于自己的工作会帮助很大，这些语句是我从大量的VBA代码中筛选出来，可以做为一些特定的通用语句来掌握，当然，以后还会陆续的给大家讲。

1 Range(“A:A”).Find(Application.WorksheetFunction.Max(Range(“A:A”))).Activate

语句说明：激活单元格区域A列中最大值的单元格

备注：这是一个以查找语句为基础的语句，Range(“A:A”).Find(Application.WorksheetFunction.Max(Range(“A:A”)))是一个查找的语句，Range(“A:A”)是查找的范围，Application.WorksheetFunction.Max(Range(“A:A”)是查找的条件，利用Application.WorksheetFunction可以调用excel的内置函数，所以可以用MAX函数来计算Range(“A:A”)中的最大值

2 Workbooks.Add()

语句说明：创建一个新的工作簿

备注：这是应用于 Workbooks 集合（对象）的 Add 方法。

3 Workbooks(“book1.xls”).Activate

语句说明：激活名为book1的工作簿

备注：Activate 是指激活，是将一个原本就是打开的工作簿显示到前台，需要注意的是“book1.xls”的后缀.xls，要和文件名显示的一致。

4 ThisWorkbook.Save

语句说明：保存工作簿

备注：SAVE是保存，相当于ctrl+s

5 ThisWorkbook.close

语句说明：关闭当前工作簿

备注：上述的写法有两种，Workbooks("book1").Close (False)和Workbooks("book1").Close (ture)

后者会提示是否保存工作表，前者不会。如下面的截图：运行的是SAVE4的代码，将会弹出

“是否保存对“BOOK1.XLS的更改？”这个对话框，供用户选择。

6 ActiveWorkbook.Sheets.Count

语句说明：获取活动工作薄中工作表数

备注：Count是数量的属性

7 ActiveWorkbook.name

语句说明：返回活动工作薄的名称

备注：name是工作表的属性。

8 ThisWorkbook.Name

语句说明：返回当前工作簿名称

ThisWorkbook.FullName

语句说明：返回当前工作簿路径和名称

备注：前者返回的仅是工作薄的名称，后者返回的是工作簿路径和名称。

9 Sheets(Sheet1).Name= “AA”

语句说明：将Sheet1命名为AA

备注：这是讲工作表重命名。

10 hisWorkbook.Sheets.Add Before:=Worksheets(1)

语句说明：添加一个新工作表在第一工作表前

备注：这是按照要求的位置添加一个工作表。

关于工作薄的代码还很多，上面是基本的语句，希望大家能理解，并在工作中加以利用，能用才会不断的进步，才会不断的提高自己。

今日内容回向：

1 什么是工作薄？

2 如何获得工作薄的路径及名称？

3 如何给工作表重命名？

1、 根据条件删除行

Sub deleteRows(strTable, condition1, condition2)

Dim i, j, iMax, jMax As Long

Dim iicondition1, iicondition2 As Integer

With Worksheets(strTable)

iMax = .UsedRange.Rows.Count

jMax = .UsedRange.Columns.Count

i = 2

Do While i < iMax + 1

iicondition1= .Cells(i, 1)

iicondition2 = .Cells(i, 2)

If (iicondition1= condition1And iicondition2 = condition2) Then

.Rows(i & ":" & i).Delete shift:=xlUp

iMax = iMax - 1

Else

i = i + 1

End If

Loop

End With

End Sub

2、 删除所以的使用range

Worksheets("sheetName").UsedRange.Delete shift:=xlUp

3、打开某指定路径的文件夹对话框

Function GetFileName(ByVal DialogType As MsoFileDialogType, ByVal defaultPath As String) As String

With Application.FileDialog(DialogType)

.Title = "XXXX:"

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add "Excel Files", "*.xlsm"

.Filters.Add "All Files", "*.*"

.InitialFileName = defaultPath

If .Show = True Then

GetFolderName = .SelectedItems(1)

End If

End With

End Function

4、截取字符段

从右边开始，查找某字符，然后截取其后面的字符串。

xlsPath2 = Right(xlsPath, InStr(StrReverse(xlsPath), "\") - 1)

5、Sharepoint数据的刷新

Worksheets("Sharepoint对应的sheet").Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False

6、当前使用的range的取得

.UsedRange ‘对应的range

.UsedRange.Rows.Count ‘对应的行号

.UsedRange.Columns.Count 对应的列号

7、在Excel内部打开另外一个Excel （不显示，隐藏）并读取其数据

Set xlsApp = New Excel.Application

xlsApp.Visible = False

xlsPath = ThisWorkbook.Path

Set xlsWB = xlsApp.Workbooks.Open(xlsPath, Null, ReadOnly)

‘读取/写入对应的sheet

X = xlsWB.worksheets(“xxxx”).cells(i,j)

xlsWB.worksheets(“xxxx”)..Cells(i, j).Formula = "=E” & i

8、计算处理

'如果你的表中有大量的计算单元格，那就需要关闭自动计算，否则慢的要死

‘在VBA开始，设置为手动

'Application.Calculation = xlCalculationManual

'Application.ScreenUpdating = False

‘在VBA开始，设置为自动

'Application.Calculation = xlCalculationAutomatic

'Application.ScreenUpdating = False

注意，还有一种方法是再打开本excel的时候，就设置为手动，对于需要计算的sheet，单独在其数据填充完毕后，执行计算操作。

例如： Worksheets("XXXXX”).Calculate ‘这是效率最高一种方法。当然，你也可以对某些range，单独进行range计算。

9、Range到range的只读拷贝、黏贴

Worksheets("srcSheet").Range(.Cells(1, 1), .Cells(x,y)).Copy

Worksheets("dstSheet").Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

10、Cell内容的替换操作

Worksheets("CostTable").Cells.Replace What:="Original Content", Replacement:="replease Content", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

11、自动填充

Worksheets("xxxx")..Range("D8:F8").AutoFill Destination:=.Range(.Cells(8, 4), .Cells(rMax, 8)), Type:=xlFillDefault

12、获取pivot的使用区域、

Set pvt = Worksheets("xxxx").PivotTables("PivotTable_xxxx")

Set rngTable = pvt.TableRange1

13、刷新pivot

Worksheets("xxxx").PivotTables("PivotTable_xxxx").PivotCache.Refresh

Visual Basic for Application（简称VBA）是一种必须依赖母系程序方能使用的程序，属于VB程序语言的一个子集。我们常用的Excel电子表格除了常规的可视化命令之外，还可以通过VBA代码来操控Excel实现一些较复杂的逻辑运算及统计分析等。我们不仅可以使用代码实现数据的统计运算，还能实现图表的自动生成于刷新，以及图形的旋转与移动。在网上我们可以找到有很多大牛基于Excel的VBA，开发了一些具有特定功能的代码，以及酷炫的游戏界面等。如果您对这方面感兴趣的话，那你必须掌握的第一步操作就是打开VBA界面来认实它。

闲话少聊，下面就重点介绍一下从Excel窗口切换到VBA界面的操作技巧。

方法一是通过功能区的选项卡来实现。首先在菜单栏中找到开发工具项，然后在代码功能模块中找到Visual Basic命令按钮，单击它即可快速切换到VBA界面。若菜单栏中没有开发工具这一项，需要设置自定义功能区下的主选项卡来调出该命令。

2.方法二是通过工作表标签来实现。首先在Excel界面左下角找到工作表标签区域，右键单击任一一个工作表标签，本教程以Sheet1工作表为例，在弹出的右键菜单中选择查看代码命令，随后即可激活VBA界面。

3.方法三是通过快捷键法实现。在Excel操作界面下，按下组合键Alt+F11即可快速切换到VBA界面；在VBA界面下按此组合键即可快速关闭VBA窗口。

在excel的使用过程中，有时候我们需要将同目录下有着相同标题的多个excel工作簿合并到一个excel工作簿中，比如下面这种情况，5个年级的学生名单合并到一个表里面去。

常用的做法是手工打开每个文件，复制粘贴到学生名单汇总一个表里去。

这里介绍一个偷懒的方法，用VBA代码自动合并。代码分4段，第1段是主代码，后面3段是自定义函数。建议把代码复制粘贴到个人工作簿的模块里，方便调用。打开学生名单汇总.xlsx ALT+F8运行该代码。

以下是具体代码，复制粘贴

Sub 同目录下合并多个excel工作簿()

'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误

Application.ScreenUpdating = False '//关闭屏幕刷新

Application.DisplayAlerts = False '//关闭系统提示

t = Timer '//开始时间

Set SH0 = ActiveWorkbook.Worksheets(1)

SH0.Cells.Clear '//清空保存区域，全部数据第一行是标题行，且只占一行，无合并单元格

ARR = FileAllArr(ActiveWorkbook.Path, "*.xlsx", ActiveWorkbook.Name, False) '//详见函数说明

SHName = "sheet1" '//要求所有工作簿内需要统计的工作表名称相同，

For i = 0 To UBound(ARR)

Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ARR(i) '//Excel2007

' Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';data source=" & & ARR(I) '//OFFICE2003，根据情况选择

StrSQL = "SELECT *,'" & GetPathFromFileName(ARR(i), False) & "' AS 来自工作簿 FROM [" & SHName & "$]" '//SQL语句自己发挥吧，这里是精髓。

IROW = SH0.Range("A1048576").End(3).Row + 1

If IROW <= 2 Then

IROW = 1

Crr = GET_SQLCoon(StrSQL, Str_coon, True) '//第一次，带上标题

Else

Crr = GET_SQLCoon(StrSQL, Str_coon, False)

End If

SH0.Range("A" & IROW).Resize(UBound(Crr, 1) + 1, UBound(Crr, 2) + 1) = Crr '//粘贴查询结果

Next

Application.ScreenUpdating = True '//恢复屏幕刷新

Application.DisplayAlerts = True '//恢复系统提示

MsgBox "汇总用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!" '//提示所用时间

End Sub

Rem 下面是为方便整理的自定义函数，上面的代码执行必不可少哟！！

'*******************************************************************************************************

'功能： 查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）

'函数名： FileAllArr

'参数1： Filename 需查找的文件夹名 不含最后的"\"

'参数2： FileFilter 需要过滤的文件名，可省略，默认为：[*.*]

'参数3： Liwai 剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name

'参数4： Files 是否只要文件夹名，可省略，默认为：FALSE

'返回值： 一个字符型的数组

'使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false)

'*******************************************************************************************************

Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal Files As Boolean = False) As String()

Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象

Set Did = CreateObject("Scripting.Dictionary")

Dic.Add (Filename & "\"), ""

i = 0

Do While i < Dic.Count

Ke = Dic.keys '开始遍历字典

MyName = Dir(Ke(i), vbDirectory) '查找目录

Do While MyName <>""

If MyName <> "." And MyName <> ".." Then

If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录

Dic.Add (Ke(i) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目

End If

End If

MyName = Dir '继续遍历寻找

Loop

i = i + 1

Loop

Dim arrx() As String

i = 0

If Files = True Then '//是否只输出文件夹名

For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例

ReDim Preserve arrx(i)

If Ke <> Filename & "\" Then '//自身文件夹除外

arrx(i) = Ke

i = i + 1

End If

Next

FileAllArr = arrx

Else

For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例

MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx

Do While MyFileName <>""

If MyFileName <> Liwai Then '排除例外文件

ReDim Preserve arrx(i)

arrx(i) = Ke & MyFileName

i = i + 1

End If

MyFileName = Dir

Loop

Next

FileAllArr = arrx

End If

End Function

'****************************************************************

'*'****************************************************************************************************

'函数: GetPathFromFileName 根据全路径获得文件名

'参数1：strFullPath 完整路径

'参数2：kzm true 返回字符串含扩展名

'参数3：strSplitor 各级文件夹分隔符

'作用: 从完整路径获取返回: 文件名(true带扩展名)

'使用方法: msgbox GetPathFromFileName("C:\windows\text.txt",true)

'*'****************************************************************************************************

Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = True, Optional ByVal strSplitor As String = "\") As String

Dim FileName1 As String

Dim FNAME As String

FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare))

FileName1 = Replace(strFullPath, FileName1, "")

If kzm = False Then

GetPathFromFileName = Left(FileName1, InStr(FileName1, ".") - 1)

Else

GetPathFromFileName = FileName1

End If

End Function

'*'****************************************************************************************************

'*****************************************************************************************

'函数名： GET_SQLCoon

'函数功能： 获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库

'返回值： 返回一个二维数组

'参数1： StrSQL 字符类型 SQL查询语句

'参数2： Str_coon 字符类型 数据库连接语句

'参数3： Biaoti 可参数选 是否输出标题，默认带有标题

'使用方法： Arr = GET_SQLCoon(StrSQL,Str_coon,true)

' Arr(0,1) '//数组第一行为标题行，从i=1 开始是数据

' Sh2.Range("A2").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR

'*****************************************************************************************

Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()

On Error Resume Next ' 改变错误处理的方式。

Dim Cn, RS

Err.Clear

Set Cn = CreateObject("Adodb.Connection") '//新建一个ADO连接

Set RS = CreateObject("adodb.recordset")

Cn.Open Str_coon

RS.Open StrSQL, Cn, 1, 3

If RS.RecordCount > 0 Then '//如果找到数据

If Biaoti = True Then

ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)

For a = 0 To RS.Fields.Count - 1 '//导入标题

ARR(0, a) = RS.Fields(a).Name

Next

For i = 0 To RS.RecordCount - 1 '//导入数据

For a = 0 To RS.Fields.Count - 1

ARR(i + 1, a) = RS.Fields(a).Value

Next a

RS.MoveNext

Next

Else

ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)

For i = 0 To RS.RecordCount - 1 '//导入数据

For a = 0 To RS.Fields.Count - 1

ARR(i, a) = RS.Fields(a).Value

Next a

RS.MoveNext

Next

End If

Else '//如果没有找到数据

ReDim ARR(1, 1)

ARR(0, 0) = ""

End If

GET_SQLCoon = ARR

Cn.Close '//关闭ADO连接

Set RS = Nothing

Set Cn = Nothing '//释放内存

End Function

'*****************************************************************************************

之前零散开发过一些自定义函数获取Excel对象属性，此次再细细地把有价值的属性都一一给开发完成，某些场景下，有这些小函数还是可以比较方便地实现一些通过Excel界面没法轻松获取到的信息。

函数清单

可在公式=》插入函数里找到此类的函数清单

大部分函数取的是单元格的一些属性。

函数清单

同时也做了个示例的文件，方便使用和查阅。

函数示例工作薄

具体函数功能

GetHyperlinksAddress函数

从网页上复制内容到Excel中比较有用，可以提取网页的超链接

GetRowHeight函数

GetColumnWidth函数

GetCellFormular函数

GetCellCommentText函数

GetCellText函数

GetCellNumberFormat函数

获取单元格的数字格式设置内容

GetCellInteriorColor函数

GetCellFontColor函数

获取单元格的字体颜色

GetRangeAddress函数

获取单元格的地址，不同参数下可获得相应的绝对、相对引用的地址格式

GetCurrent相关函数

获取工作表、工作薄的名称信息

总结

万丈高楼平地起，任何一个精彩的Excel应用，都是多方的知识和功能联合造就的，这些小小的自定义函数，某些时候会是某个数据应用里一个很不错的功能落地点。积累多一些知识，真正应用时就可以有丰富的智囊可供使用。

欢迎关注天善智能，我们是专注于商业智能BI，大数据，数据分析领域的垂直社区，学习，问答、求职一站式搞定！

天善学院618活动正在进行中！天善学院618大礼包，大数据、数据分析与数据挖掘、商业智能、机器学习、深度学习、数据库与数据仓库、R语言、Python精品课程总有一款正中你下怀吧？全场6.18折，赠送微课。最好的投资是投资自己，名额有限，欢迎登录查看！

因为还没有熟练掌握用Ruby生成excel的技能，所以干脆学了一点VBA，写了段通过excel实时获取股票数据的代码。

方便在excel里使用各种公式计算涨跌幅。

分享如下：

效果如下：

本文作者：GalaxyRover

在excel办公中，用VBA加上SQL语句实现对excel表格的数据获取，对于处理一些大数据量的表格来说是非常实用的。SQL是结构化查询语言，是数据库开发中用的程序设计语言，数据库里的数据表跟EXCEL里的表格其实是很类似的，所以用VBA加SQL语句可以实现类似的表格查询操作。

举个例子：在EXCEL里用VBA+SQL来查询总成绩大于290分的学生

一、手工操作的步骤是：

1、 EXCEL打开如下表格，点击插入-数据透视图，点击创建数据透视图

2、 在出现的数据透视图界面，点击姓名为行标签，点击成绩为求和项字段

3、 在左侧的出现的行标签和求和项表格数据进行排序，手工选出成绩大于290分的记录。

用上面的数据透视图方法很方便，步骤也少，比分类汇总功能要简便些。

二、VBA加上SQL语句实现EXCEL表格数据的查询

1、 先用EXCEL打开表格，调出VBE工程界面（ALT+F11），建议在个人工作簿新建个模块，把代码输入到右侧的区域。注：用个人工作簿的好处是，每次启动EXCEL不用手动启用宏。

2、 根据自己的表格字段和功能需求，修改好SQL代码后，保存按F5快捷键运行。注：SQL语句中表名要用[表名$]这种写法。

以上是在EXCEL用VBA加SQL语句实现对表格的自动查询，调用的方法是按ALT+F8,选择相应的代码名称，这里的名称是SQL查询。用这种方法对于规则不经常变动的情况下使用很实用，特别是在数据量大的情况下。

附上截图代码

Sub SQL查询()

Dim cnn As Object, rs As Object, SQL As String

Set cnn = CreateObject("adodb.connection") '创建数据库连接

cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ActiveWorkbook.FullName

Set rs = CreateObject("adodb.recordset") '创建一个数据集

SQL = "select 姓名,sum(成绩) from [原始数据$] group by 姓名 HAVING sum(成绩)>290" '设置SQL查询语句，这个根据实际需要改写，注意【表名$】这种写法

Set rs = cnn.Execute(SQL) '执行查询

ActiveWorkbook.Worksheets(2).Cells.ClearContents

Dim i As Integer

For i = 1 To rs.Fields.Count

ActiveWorkbook.Worksheets(2).Cells(1, i) = rs.Fields(i - 1).Name '填写标题到表2

Next

ActiveWorkbook.Worksheets(2).Range("a2").CopyFromRecordset rs '复制记录集到表2

rs.Close

Set rs = Nothing

cnn.Close

Set cnn = Nothing

End Sub

对于EXCEL2007版本的电子表格，以上的cnn.Open后的字符串要改成"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""

前言

首先需要感谢看官您抽空观赏本文，若有任何问题，欢迎您的指正。

另外大家若有什么好的想法或者效果需求，可以在评论区留言或者私信我，我会尽力尝试做一做。

如果您喜欢本文的话，可以点赞、订阅、关注、收藏、留言评论哦！谢谢！O(∩_∩)O~~

情景还原 - 请您听我说

Excel - VBA 让表格处理变得更简单、更便利、更有趣。

平常我们从其他Excel表格Copy数据出来的时候，往往都会将源数据表格打开，然后提取我们所需要的部分数据；

将这个流程整理出来就是：①打开文件资源管理器，花若干秒找到文件；②花若干秒打开文件；③选中全文并Copy（若不熟练Excel快捷键等，可能Copy过程要多耽误几秒）；④回到需要数据的文档粘贴下来（若开的文件较多，可能切换时也要耽误几秒）。

那这上面的看似复杂的流程，可否有便利快捷的办法完成呢？

答案肯定是 —— 有。用VBA代码就能将上面的流程简化到只要【找文件】这一步。

功能介绍 - “吹”来“吹”去

流程简洁方便，只需要找到那份文档即可；

若源数据文档只有一个工作表，则直接汇入数据；

若待汇入源数据文档含有多个工作表，会提示选择需要汇入的表格；

若输入非关键值，则会报错并重新提示输入值。

效果演示 - 调皮的 GIF 环节

依旧是那句：万般文字也不如一个视频或者一张GIF演示来的痛快，请看官您静静观赏。

首先是一份正常使用情况下的完成流程：

调皮的 GIF 图有点点长 ~.~

当输入关键字时，输入非列表内的对应序号，则会报错提示，并重新回到输入关键字的界面：

确认选择的文件

输入 “WW” 不符合要求

报错提示信息

输错啦！请重新输入.GIF

VBA代码 - Tab / Space

效果演示看完了，那么就为您附上代码，供您慢慢检验：

VBA 代码

PS：若有看官觉得图片还不够清晰，无法尝试，您可以在评论区留言，我会私信回复您。若需要代码的看官比较多（比如100位），那么我会将文本代码直接以文章推送出来供大家查阅。

【关于私信，目前可能需要看官您先发送私信给我，作为作者这边无法直接向您发信息，若您曾给我发过私信且未将对话关闭，我这边就能从历史记录中向您发送信息。】

文末 - 谢谢您嘞，(づ￣3￣)づ╭

每一位读者的点赞、订阅、关注、收藏、留言评论都是对我的最大支持，谢谢各位帅哥美女！

同时也希望大家多多转发与评论留言，毕竟只有更多的人认可，我才更有动力为大家发布文章，提供代码。

再次谢谢大家！

友情链接 - 值得一看

1、Excel-VBA 让录入数据变得更智能——输入时提示匹配值

2、Excel-VBA 将乱序的数据剔除空值后有序排列成一列或一行

3、Excel-VBA 实时记录表格异动

4、Excel-VBA “十字星”聚焦效果