Excel 的相关操作(VB)

Question

以下是VBA中的代码，请问各位达人，要怎样修改才能拿给VB用呢！
另外，在VB中怎样连接和读写Excel比较好呢？谢谢各位达人！！
    Sheets("Sheet1").Copy Before:=Sheets(2)
    Range("A7").Select
    ActiveCell.FormulaR1C1 = "XXXX"
    Sheets("Sheet1 (2)").Select
    Sheets("Sheet1 (2)").Name = "XXXX"
    Sheets("Sheet2").Select
    ActiveCell.FormulaR1C1 = "XXXX"
    With ActiveCell.Characters(Start:=1, Length:=5).Font
        .Name = "Times New Roman"
        .FontStyle = "³£¹æ"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With

Answer 1

Option ExplicitPublic Const FO_MOVE As Long = &H1
Public Const FO_COPY As Long = &H2
Public Const FO_DELETE As Long = &H3
Public Const FO_RENAME As Long = &H4
Public Const FOF_MULTIDESTFILES As Long = &H1
Public Const FOF_CONFIRMMOUSE As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_WANTMAPPINGHANDLE As Long = &H20
Public Const FOF_CREATEPROGRESSDLG As Long = &H0
Public Const FOF_ALLOWUNDO As Long = &H40
Public Const FOF_FILESONLY As Long = &H80
Public Const FOF_SIMPLEPROGRESS As Long = &H100
Public Const FOF_NOCONFIRMMKDIR As Long = &H200Type SHFILEOPSTRUCT
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Long
     fAnyOperationsAborted As Long
     hNameMappings As Long
     lpszProgressTitle As String
End Type
Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPrivate Sub Command1_Click()
 
    Dim xlsApp As Excel.Application
    Dim xlwb As Excel.Workbook
    
    Dim wdApp       As Word.Application
    Dim wbzhishu    As Word.Document
    
    Dim astrData() As String
    
    Dim fileop As SHFILEOPSTRUCT
    Dim result As Long
    Dim winHwnd As Long
    Dim RetVal As Long
    
    Dim intIndex As Integer
    Dim intRow As Integer
    Dim intCol As Integer
    
    Dim myRange
    Dim myRange1
    
    Dim strTemp As String
    
    Dim intFirst As Integer
    
    Dim intSecond As Integer
    
    If Text1.Text = "" Then
        MsgBox "请选择EXCEL文件", vbExclamation
        GoTo PROC_EXIT
    End If
    
    If MsgBox("请确认选择的文件里有表名为'sheet1'", vbExclamation + vbOKCancel) = vbCancel Then GoTo PROC_EXIT
    
    If Text3.Text = 0 Then
        MsgBox "请输入工资记录数", vbExclamation
        GoTo PROC_EXIT
    End If
    
    If MsgBox("确认将数据转换成WORD格式", vbExclamation + vbOKCancel) = vbCancel Then GoTo PROC_EXIT
    
    Label4.Caption = "正在准备转换数据"
    
    Screen.MousePointer = vbHourglass
    
    '检测word程序是否正在运行，如果是则关闭它，可以使用如下代码来实现：
    winHwnd = FindWindow(vbNullString, "工资单 - Microsoft Word")
    If winHwnd <> 0 Then
        SendMessage winHwnd, WM_CLOSE, 0, 0
    End If
    
    '检测EXCEL程序是否正在运行，如果是则关闭它，可以使用如下代码来实现：
    
    Dim astrFile() As String
   astrFile = Split(strFileName, "\")
   
   strTemp = astrFile(UBound(astrFile()))
   
   astrFile = Split(strTemp, ".")
   
   strTemp = " Microsoft Excel - " & astrFile(0) & " "
    
    winHwnd = FindWindow(vbNullString, strTemp)
    If winHwnd <> 0 Then
        SendMessage winHwnd, WM_CLOSE, 0, 0
    End If
        
    On Error Resume Next
        
    Kill App.Path & "\工资单.doc"
        
    'On Error GoTo PROC_ERR
    
    '对预设的格式文件进行copy
    With fileop
        .hwnd = Me.hwnd
        .wFunc = FO_COPY
        .pFrom = App.Path & "\工资单样本.doc"
        .pTo = App.Path & "\工资单.doc"
        .fFlags = FOF_SIMPLEPROGRESS Or FOF_FILESONLY
    End With
        
    result = SHFileOperation(fileop)
    
    Set wdApp = CreateObject("word.Application")
    
    Set wbzhishu = wdApp.Documents.Open(fileop.pTo)
    
    Set xlsApp = CreateObject("Excel.Application")    Set xlwb = xlsApp.Workbooks.Open(strFileName)
    
    'xlsApp.Sheets("sheet1").Select
    
    ReDim astrData(0 To intCount, 1 To 27)    intIndex = 0
    
    intRow = 1    strTemp = "A3:AA" & (intCount + 2)    Dim c
    For Each c In xlsApp.Sheets("sheet1").Range(strTemp)
    
            intIndex = intIndex + 1
            astrData(intRow, intIndex) = c.Value
            
            If intIndex Mod 27 = 0 Then
                intRow = intRow + 1
                intIndex = 0
            End If
    Next c
    
    
    Set myRange = wdApp.ActiveDocument.Content
    myRange.Copy
    
    For intIndex = 1 To intCount - 1
        myRange.Collapse Direction:=wdCollapseEnd
        myRange.InsertBreak Type:=wdSectionBreakNextPage
        myRange.Paste
        
        Label4.Caption = "复制表格格式已完成：" & intIndex & "/" & intCount
        DoEvents
    Next intIndex    With wdApp.ActiveDocument
    
        For intFirst = 1 To intCount
        
           myRange.Find.Execute FindText:="hi", ReplaceWith:="hello", Replace:=wdReplaceAll
            
            strTemp = "部门：" & astrData(intFirst, 27) & Space(5) & "姓名：" & astrData(intFirst, 1) & Space(5) & "月份：  " & Combo1.Text
            
            
            Set myRange = wdApp.ActiveDocument.Content
            myRange.Find.Execute FindText:="DEPT", Forward:=True
            If myRange.Find.Found = True Then
                myRange.Text = strTemp
            End If            
            With .Tables(1 + (intFirst - 1) * 3)
            
                For intSecond = 1 To 3
                    
                    .Cell(3, intSecond).Range = astrData(intFirst, intSecond)
                    
                Next intSecond
        
            End With
            
              
            With .Tables(2 + (intFirst - 1) * 3)
            
                For intSecond = 1 To 10
                    .Cell(3, intSecond).Range = Format(astrData(intFirst, intSecond + 3), "#0.00")
                Next intSecond
            End With
            
            With .Tables(3 + (intFirst - 1) * 3)
            
                For intSecond = 1 To 12
                    .Cell(3, intSecond).Range = Format(astrData(intFirst, intSecond + 13), "#0.00")
                Next intSecond
            End With
            
            
            Label4.Caption = "插入工资数据已完成：" & intFirst & "/" & intCount
            DoEvents
            
        Next intFirst
        
    End With
    
     Set myRange = wdApp.ActiveDocument.Range(Start:=wdApp.ActiveDocument.Paragraphs(1).Range.Start, _
                                End:=wdApp.ActiveDocument.Paragraphs(1).Range.End)
    myRange.Font.Size = 15
    myRange.Font.Bold = wdToggle    wdApp.Visible = True
    wdApp.DisplayAlerts = wdAlertsMessageBox
    
    Label4.Caption = ""
    
    xlsApp.Visible = True
    xlsApp.Quit
    Set xlsApp = Nothing
    Set xlwb = Nothing
    Screen.MousePointer = vbDefault
    
    
PROC_EXIT:  
    Exit Sub
    
PROC_ERR: ' 错误处理程序。    On Error Resume Next
    Screen.MousePointer = vbDefault
        xlsApp.Visible = True
    
    DoEvents
    
    '如果在打开对话框里选择取消,则忽略错误
    If Err.Number = 32755 Then GoTo PROC_EXIT
    
    MsgBox Err.Description, vbExclamation
    GoTo PROC_EXITEnd Sub

Answer 2

楼主,有没在VB里试过？
引用“Microsoft Excel x.y Object Library”，其中x.y是版本号，取决于你机器上安装的Office版本