请问如何使用VB查找替换excel中指定字符 - VB6论坛

得分:0

1、读取execl到内存数组txt1,之后操作二维数组txt1即可
'============================================================
'  读取EXECL到内存数组【速度快-优选】
'  输入参数：execl名字、sheet名【需要ADO控件】【Activex  Data Object】
'  输出参数：txt1内存数组
'============================================================
Public Sub read_Execl(ByVal execl_name As String, ByVal sheet1 As String, txt1)
  Dim cn As New ADODB.Connection
  Dim rs As New ADODB.Recordset
  Dim i As Long, j As Long
  If Right(execl_name, Len(execl_name) - InStrRev(execl_name, ".")) = "xls" Then
   cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;data source=" & execl_name & ";extended properties= 'Excel 8.0;HDR=YES;IMEX=1';"
  ElseIf Right(execl_name, Len(execl_name) - InStrRev(execl_name, ".")) = "xlsx" Then
   cn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Persist Security Info=False;data source=" & execl_name & ";extended properties= 'Excel 12.0;HDR=YES;IMEX=1';"
  End If
  rs.Open "select * from [" & sheet1 & "$]", cn, 1, 1
  ReDim txt1(rs.RecordCount, rs.Fields.Count)
  For i = 1 To rs.Fields.Count: txt1(0, i) = rs.Fields(i - 1).Name: Next i '读第一行【首行当标题了】
  For i = 1 To rs.RecordCount '读其余行
    For j = 1 To rs.Fields.Count: txt1(i, j) = rs.Fields(j - 1): Next j
    rs.MoveNext
  Next i
  rs.Close
  Set rs = Nothing
  Set cn = Nothing
End Sub
2、保存execl
'==============================================================================
'                          保存Execl
'【需要引用Microsoft Execl 12 objects Library】
' 输入：txt1二维数组、Execl的Sheet位置；输出：Execl文件
'==============================================================================
Public Sub Write_Execl(ByVal Execl_name, ByVal sheet1, ByVal txt1)
   Dim NewXls As Excel.Application
   Dim NewBook As Excel.Workbook
   Dim NewSheet As Excel.Worksheet
   Dim objRange As Object
   Dim nRows As Long, nColumns As Long
   Set NewXls = CreateObject("Excel.Application") '创建excel应用程序,打开excel2000
       NewXls.SheetsInNewWorkbook = sheet1
   Set NewBook = NewXls.Workbooks.Add '创建工作簿
   Set NewSheet = NewBook.Worksheets(sheet1) '创建工作表
       NewXls.DisplayAlerts = False
       nRows = UBound(txt1, 1)
       nColumns = UBound(txt1, 2)
   '导出到Excel中
   Set objRange = NewSheet.Range(NewSheet.Cells(1, 1), NewSheet.Cells(nRows, nColumns))
       objRange.Value = txt1
       DoEvents
       If Right(Execl_name, Len(Execl_name) - InStrRev(Execl_name, ".")) = "xls" Then
         NewBook.SaveAs Execl_name, 56 'Excel 97-2003 工作簿
       ElseIf Right(Execl_name, Len(Execl_name) - InStrRev(Execl_name, ".")) = "xlsx" Then
         NewBook.SaveAs Execl_name, 51
       End If
       NewBook.Close
   Set NewBook = Nothing
   Set NewXls = Nothing
End Sub