使用ADO快速导入Excel
第一次使用md写日志。以下代码也是2014年左右写的,好怀念!
代码说明
代码作用是快速地将其他excel文件下追加导入到当前excel中。主要使用ado方式导入。具体代码也是在google上搜索修改的。(如果以后找到了原作者我会把连接加进去)
vba代码
主要实现三个功能:
– 将一个sheet拷贝到当前sheet
– 将多个sheet拷贝到当前sheet
– 清空已拷贝的内容
文件定义的常量
' 开发模式
#Const developMode = False
' 源excel名
Const workbookName = "hello_world"
' 源sheet名
Const sheetName As String = "sheet1"
' 源sheet页列宽
Const totalCol As Integer = 31
将一个sheet拷贝到当前sheet
注意:vba使用 “_” 表示换行符
Private Sub LoadFileBtn_Click()
Dim lastRowNum As Long
Dim FName As Variant
Dim destrange As Range
Dim sh As Worksheet
' 计算当前sheet拷贝的位置
' vba只能在激活sheet使用,若要操作其他sheet要先激活
Set sh = Application.ActiveSheet
lastRowNum = lastRow(sh)
Set destrange = sh.Cells(lastRowNum + 1, "A")
#If developMode Then
Debug.Print "current sheet name: " & sh.Name
Debug.Print "copy base addr: " & destrange.Address(external:=True)
Debug.Print "copy base addr: " & destrange1.Address(external:=True)
#End If
Application.ScreenUpdating = False
' 文件操作
FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xls")
If InStr(FName, workbookName) = 0 Or Right(FName, 4) <> ".xls" Then
MsgBox ("请选择正确的xls文件!例如:" & workbookName & ".xls")
Exit Sub
End If
If FName = False Then
Else
#If developMode Then
Debug.Print "open file name: " & FName
#End If
'fileNameStr = Mid(FName, InStrRev(FName, "\") + 1)
Dim totalRow As Long
'获得目标文件的最后一行
'但是对于宽度无法动态获得,所以定义了常量totalCol
totalRow = GetRowNum(FName, sheetName)
#If developMode Then
Debug.Print "totalRow: " & totalRow
#End If
' 调用拷贝函数
GetData FName, sheetName, _
"A2:" & Cells(totalRow, totalCol).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
destrange, False, False
End If
Application.ScreenUpdating = True
End Sub
将多个excel拷贝到当前sheet
Private Sub BatchLoadBtn_Click()
Dim FName As Variant
Dim destrange As Range
Dim sh As Worksheet
Dim rowNum As Long
Dim n As Integer
Set sh = Application.ActiveSheet
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", MultiSelect:=True)
' 返回一个arrayList,即便只有一个元素
If IsArray(FName) Then
FName = Array_Sort(FName)
Application.ScreenUpdating = False
' 循环调用单个拷贝LoadFileBtn_Click函数
For n = LBound(FName) To UBound(FName)
' 跳过不满足条件的xls
If InStr(FName(n), workbookName) <> 0 And Right(FName(n), 4) = ".xls" Then
#If developMode Then
Debug.Print "N: " & n & " fName: " & FName(n)
#End If
rowNum = lastRow(sh)
Set destrange = sh.Cells(rowNum + 1, "A")
Dim totalRow As Long
totalRow = GetRowNum(FName(n), sheetName)
Dim totalCol As Long
totalCol = GetColNum(FName(n), sheetName)
GetData FName(n), sheetName, _
"A2:" & Cells(totalRow, totalCol).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
destrange, False, False
End If
Next
End If
Application.ScreenUpdating = True
End Sub
清空已拷贝的内容
' 将从第3行到最后一行所有内容清空
Private Sub ClearBtn_Click()
'Range("A3:" & "AE" & Rows.Count).ClearContents
Rows("3:" & Rows.Count).ClearContents
End Sub
上面代码用到的函数
1.将源sheet拷贝到目标sheet
vba只能操作当前激活的sheet,故目标sheet就是当前激活的sheet页
ADO知识
ADO使用游标
如何关闭debug输出?
在vba开头定义 Const developMode = False
' SourceFile 源excel文件名
' SourceSheet 源sheet名
' SourceRange 源拷贝的cells范围
' targetRange 目的cells范围
' Header 是否包含了第一行
' UseHeaderRow 拷贝范围包含了头行
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _SourceRange As String, targetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
' 0向前,1只读,1(?)
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
targetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
targetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
targetRange.Cells(2, 1).CopyFromRecordset rsData
Else
targetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
'MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
'vbExclamation, "Error"
On Error GoTo 0
End Sub
2.获取sheet最大行数
' SourceFile 源文件名
' SourceSheet 源sheet名
' 返回sheet最大行数
Public Function GetRowNum(SourceFile As Variant, SourceSheet As String)
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
GetRowNum = 0
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' wps走这里
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
#If developMode Then
Debug.Print "-------"
Debug.Print "szConnect: " & szConnect
#End If
Dim sqlRow As String
' 组合形成sql语句,加入文件名和sheet
'sqlRow = "select count(*) from [Sheet1$A:A]"
If SourceSheet = "" Then
Exit Function
Else
' SELECT COUNT(*) FROM [柜员情况表$A:A];
' select count(*) from [Sheet1$A:A]
sqlRow = "SELECT COUNT(*) FROM [" & SourceSheet$ & "$A:A];"
'sqlRow = "select * from [Sheet1$2:2]"
#If developMode Then
Debug.Print "-------"
Debug.Print sqlRow
#End If
End If
'On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open sqlRow, rsCon
If Not rsData.EOF Then
GetRowNum = rsData.Fields(0)
' 可以获得列长度,但是不准确
'GetRowNum = rsData.Fields.Count
End If
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Function
SomethingWrong:
'MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
'vbExclamation, "Error"
On Error GoTo 0
End Function
3.获得最后一列
vba中cells.find函数
XlWhole 完全匹配,xlPart 部分匹配
xlValues、xlFormulas或者xlComments,对应查找范围,按值,公式,批注
' 说明:从第一个位置,按列向后查找,找到最后一列,返回改列的行值
' sh vba中sheet对象
' 返回vab中column对象
Function lastColumn(sh As Worksheet)
On Error Resume Next
lastColumn = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
lookat:=xlPart, _
LookIn:=xlFormulas, _
searchorder:=xlByColumns, _
searchdirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
4.获得最后一行
' sh vba中sheet对象
' 返回vab中row对象
Function lastRow(sh As Worksheet)
On Error Resume Next
lastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
lookat:=xlPart, _
LookIn:=xlFormulas, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
5.排序函数
' 将ArrayList排序(双重循环,置换)
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function
6.查找指定的字符串
本文中未使用该函数
' targetStr 要查询的字符串
' where 查询范围
' 返回 true/false
Function isExist(targetStr As String, where As Range)
If Not Len(targetStr) = 0 Then
isExist = where.Find(what:=targetStr, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
End If
End Function
7.查找指定一列的最大行号
本文中未使用该函数
' singleCol 查找的目标列(单列)
' 返回true/false
Function FindLastEmptyRow(singleCol As Range)
FindLastEmptyRow = singleCol.Find(what:="*", LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
End Function
今天的文章vba使用adodb完整举例_导入仪导出前要擦什么[通俗易懂]分享到此就结束了,感谢您的阅读,如果确实帮到您,您可以动动手指转发给其他人。
版权声明:本文内容由互联网用户自发贡献,该文观点仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 举报,一经查实,本站将立刻删除。
如需转载请保留出处:https://bianchenghao.cn/58216.html