如何使用VBA代码提取excel工作表数据

代码复制到 报表 代码窗口，不要弄反了哦

Sub 获取数据()

x = WorksheetFunctionMatch([A1], Sheets("数据")Range("B:B"), 0)

arr = Sheets("数据")Range("d" & x & ":" & "h" & x)

[b4]Resize(1, 5) = arr

[b5] = Sheets("数据")Cells(x, "i")

End Sub

或

Sub 获取数据()

y = WorksheetFunctionCountIf(Sheets("数据")Range("B:B"), [a1])

If y = 0 Then

MsgBox "日期输入错误"

Exit Sub

End If

x = WorksheetFunctionMatch([a1], Sheets("数据")Range("B:B"), 0)

arr = Sheets("数据")Range("d" & x & ":" & "h" & x)

[b4]Resize(1, 5) = arr

[b5] = Sheets("数据")Cells(x, "i")

End Sub

创建宏,在代码框输入:

Dim b As Integer

For Each a In Selection

b = b + 1

Next a

Range("a1")Select

ActiveCellValue = b

选中你这个数据区的首行,然后运行结果我是在A1里面显示的

其实用函数可以简单得出为什么要用VBA呢

1、将单元格所选单元格的行号和列号，分别用VBA显示在下面的两个单元格中，如下图所示：

2、按下Alt+F11，打开VBA编辑界面，选择当前工作表编写代码，如下图所示：

3、下面代码是得到当前单元格的行号并放到当前单元格下一个单元格中：

4、下面代码是得到当前单元格的列号并放到当前单元格下面第二个单元格中：

5、代码编写完成，点击运行子过程按钮（或按下F5）

6、返回Excel中，就可以看到得到了当前单元格的行号和列号

可能以上的三种方式，你还是不太熟悉，我们举一个通俗一点例子：

1、对象cells（rowsindex，colunmindex）

假如我们想在sheet1中的A1单元格输入100，是这样写代码的。

Worksheets("sheet1")Cells(1, 1) = 100

我们来说说cells（1,1）的含义，前面的一个数字1，代表的是第一行，后面的一个1代表的是第一列。是不是发现使用Cells比range更好理解一点呢？

PS：需要说明的是在我们excel种使用Cells这个时候，他的行和列是有最大值的，我们一旦超过最大值就会报错。行的最大值为1048576，列的最大值为16384

2、对象cells（rowindex）

这个使用方法很简单也很有意思，他的最大值为行和列的所有单元格数目相加，即他的最大值为17179869184这个数字和我们的Excel中的单元格的数目是相等的。理解这个的时候，可以这么理解，单元格从A1到XFD1换行，然后A2到XFD2，如此进行循环。

假如我们想在第520个单元格输入这个值，那么代码是如何去写写呢？

其实很简单的, Worksheets("sheet1")Cells(520) = 520

这代码的意思就是在第520个单元格输入520值。

3、对象cells

这个的使用方法可以说是非常强大的，这种方法返回的是所有工作表上的单元格，请注意和前面的2种方法区分来。

例1， 假如我们需要清除sheet1中的单元格的所有值，代码是这样写的。

代码为Worksheets("sheet1")CellsClear，这个的意思就是清除单元格中的所有内容。这个在我们清除单元格的内容的时候用的很多的。

1GetAttr 函数

语法：GetAttr(pathname)

功能：获取一个文件、目录、或文件夹的属性。返回一个 Integer值。

返回值

由 GetAttr 返回的值，是下面这些属性值的总和：

常数 值 描述

vbNormal 0 常规

vbReadOnly 1 只读

vbHidden 2 隐藏

vbSystem 4 系统文件

vbDirectory 16 目录或文件夹

vbArchive 32 存档文件

vbalias 64 指定的文件名是别名。只在Macintosh中可用。

说明：若要判断是否设置了某个属性，在 GetAttr 函数与想要得知的属性值之间使用 And 运算符与逐位比较。如果所得的结果不为零，则表示设置了这个属性值。

示例：

DebugPrint GetAttr("F:\testtxt") '若为存档文件，在立即窗口可看到值为32

DebugPrint GetAttr("F:\testtxt") '将属性—高级—可存档文件的勾去掉后，值为0

为判断一个文件是否只读，可用下法:

DebugPrint GetAttr("F:\testtxt") And vbReadOnly

若值非零，说明时只读的。

2复制

'

' （1） 在不需要逐个打开工作簿的情况下,将其有效工作表依次复制到本工作簿的最后

' 新工作表名为:原工作簿名_原工作表名

'

' Sub 复制工作表()

Dim MyObject As Object

Dim strPath As String, strFileName As String, strMyName As String

Dim shtSheet As Worksheet, strShtName As String

Dim intCount As Integer, intShtCount As Integer, i As Integer

ApplicationScreenUpdating = False

strPath = ThisWorkbookPath

strMyName = ThisWorkbookName

intShtCount = ThisWorkbookSheetsCount

With ApplicationFileSearch

NewSearch

LookIn = strPath

SearchSubFolders = False

Filename = "xls"

FileType = msoFileTypeOfficeFiles

If Execute() > 0 Then

intCount = FoundFilesCount

For i = 1 To intCount

strFileName = Replace(FoundFiles(i), strPath & "\", "")

If strFileName <> strMyName Then

Set MyObject = GetObject(strPath & "/" & strFileName)

'下面进行复制工作

For Each shtSheet In MyObjectWorksheets

strShtName = shtSheetName

If MyObjectSheets(strShtName)UsedRangeCount > 1 Then

MyObjectSheets(strShtName)Copy After:=ThisWorkbookSheets(intShtCount)

intShtCount = intShtCount + 1

'重新命名

strShtName = Replace(strFileName, "xls", "_") & strShtName

ThisWorkbookSheets(intShtCount)Name = strShtName

ThisWorkbookSheets("目录")Cells(i + 1, 1) = strShtName

End If

Next shtSheet

End If

Next i

Else

MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"

End If

End With

ThisWorkbookSheets("目录")Select

ApplicationScreenUpdating = True

End Sub

'

'（2） 逐个打开同一目录下的所有工作簿,将其有效工作表依次复制到本工作簿的最后复制完后关闭它

' 新工作表名为:原工作簿名_原工作表名

'

Sub 复制工作表_2()

Dim MyObject As Object

Dim strPath As String, strFileName As String, strMyName As String

Dim shtSheet As Worksheet, strShtName As String

Dim intCount As Integer, intShtCount As Integer, i As Integer

ApplicationScreenUpdating = False

strPath = ThisWorkbookPath

strMyName = ThisWorkbookName

intShtCount = ThisWorkbookSheetsCount

With ApplicationFileSearch

NewSearch

LookIn = strPath

SearchSubFolders = False

Filename = "xls"

FileType = msoFileTypeOfficeFiles

If Execute() > 0 Then

intCount = FoundFilesCount

For i = 1 To intCount

strFileName = Replace(FoundFiles(i), strPath & "\", "")

If strFileName <> strMyName Then

'WorkbooksOpen Filename:=strPath & "/" & strFileName

Set MyObject = GetObject(strPath & "/" & strFileName)

'下面进行复制工作

For Each shtSheet In Workbooks(strFileName)Worksheets

strShtName = shtSheetName

If Workbooks(strFileName)Sheets(strShtName)UsedRangeCount > 1 Then

Workbooks(strFileName)Sheets(strShtName)Copy After:=ThisWorkbookSheets(intShtCount)

intShtCount = intShtCount + 1

'重新命名

strShtName = Replace(strFileName, "xls", "_") & strShtName

ThisWorkbookSheets(intShtCount)Name = strShtName

ThisWorkbookSheets("目录")Cells(i + 1, 1) = strShtName

End If

Next shtSheet

'Workbooks(strFileName)Close

End If

Next i

Else

MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"

End If

End With

ThisWorkbookSheets("目录")Select

ApplicationScreenUpdating = True

End Sub

Function FileCount(cPath As String) as Integer

    cFile=Dir(cPath & "")

    Do While cFile<>""

        FileCount=FileCount+1

        cFile=Dir

    Loop

End Function

这是一段自定义函数，在Excel VBA编辑模式下，主菜单“插入”——“模块”，将代码粘贴到右侧编辑区。如果在工作表状态下使用，在单元格输入：=FileCount("c:\XXX\")就可以得出c:\XXX文件夹下的所有文件个数（不含子文件夹)；如果在代码中使用，则可以：nFileCount=FileCount("c:\XXX\")得到文件个数。注意：cPath参数必须以“\”符号结尾。

1、按alt+F11打开vba编辑器；

2、输入以下代码

MsgBox "sheet1共有" & Sheet1UsedRangeRowsCount & "行记录。"

End Sub

3、点击运行。

以上就是关于如何使用VBA代码提取excel工作表数据全部的内容，包括:如何使用VBA代码提取excel工作表数据、如何用vba语言获得excel当前工作表数据区的列数、vba如何读取excel中某单元格的行数或列数等相关内容解答，如果想了解更多相关内容，可以关注我们，你们的支持是我们更新的动力！