无法使用VB6将数据加载到Excel 2013中的其他选项卡中

Question

在我的组织中，我们有一个基于Visual Basic 6.0的旧项目/应用程序

在该应用程序中，我们已导出到Excel“按钮”，单击该按钮即可将数据填充到电子表格的不同选项卡中。 它在Excel 2010以及以后的版本中运行良好，直到我们移至EXCEL 2013 。

问题： 我们需要将数据导出到excel 2013中的2个标签中，而仅将其导出到1个标签中。 我尝试使用打包和部署向导以及所有可能的帮助。 到目前为止没有运气。 如果您有任何疑问或不清楚，请告诉我。 请在下面找到我的代码。

Dim uprev As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlsheet2 As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean   ' Flag for final release.
Dim n As Integer
Dim n1 As Integer
Dim n2 As Integer
Dim i As Integer
Dim lastrevdate As String
Dim lastrevrow As Integer
Dim lastrow As Integer
Dim previouspcno As Integer
Dim xlcol As String
Dim j As Integer
Dim k As Integer

Dim dc As Adodc
Dim mrc As Recordset

Dim qpa As New QPArray
Dim Found As Long
Dim StartInd As Long
Dim bFound As Boolean
Dim crlf As String

On Error GoTo errorhandler1

crlf = Chr(13) & Chr(10)


ReDim qs(10) As String
ReDim q(10) As Integer
ReDim hdr(15) As Integer
ReDim rev(10, 0) As String
ReDim part(0) As String
ReDim sl(nof) As String
ReDim cmpsql2(0) As String
ReDim deletedfromsql(3, 0) As String
Dim doThis As Integer
Dim iReturn As Integer

Dim revlev As String
Dim Date_Engr As String
Dim Date_Checker As String



'On Error Resume Next   ' Defer error trapping.
'Removed, not checking to see if excel is open properly
'Bert - 6/5/07
'Set xlApp = GetObject(, "Excel.Application")
'If Err.Number <> 0 Then
'    ExcelWasNotRunning = True
'Else
'    MsgBox ("Please Close Excel before continuing")
'    Exit Sub
'End If
Err.Clear   ' Clear Err object in case error occurred.

iReturn = MsgBox("Please Close ALL Excel applications before continuing", vbOKOnly, "WARNING")

ExcelWasNotRunning = True


'fixwidth

Screen.MousePointer = vbHourglass

'DetectExcel



Set xlApp = Excel.Application

'path(8) = "C:\SwitchGear\Files1\eng_prod\Jobs\cs01157\medt\"
If Dir(Defaults.medt & "\" & cs & sos & "mbom.xls", vbNormal) <> "" Then

    mbomflag = 1


    FileCopy Defaults.medt & "\" & cs & sos & "mbom.xls", Defaults.medt & "\" & cs & sos & "mbom.bak"
    Set xlBook = GetObject(Defaults.medt & "\" & cs & sos & "mbom.xls")
    Set xlSheet = xlBook.Worksheets(1)
    Set xlsheet2 = xlBook.Worksheets(2)

    Do
        qs(1) = "1. Do not list changes on rev sheet" & crlf
        qs(1) = qs(1) & "2. list changes on rev sheet but do not increase rev level" & crlf
        qs(1) = qs(1) & "3. list changes on rev sheet and increase rev level"
        qs(0) = InputBox(qs(1))
        If qs(0) = "" Then Exit Sub
    Loop Until qs(0) > "0" And qs(0) < "4"



    If qs(0) = "3" Then ' up the revision
        uprev = 2
        revlev = xlsheet2.Cells(5, 3) + 1
        Date_Engr = Date
        Date_Checker = Date
    Else
        uprev = 1
        revlev = xlsheet2.Cells(5, 3)
        Date_Engr = xlSheet.Cells(16, 2) ' get the old rev number
        Date_Checker = xlSheet.Cells(16, 3)

    End If

    lastrow = xlSheet.Cells.Range("E20").End(xlDown).Row

    ReDim cmpxl2(0) As String
    ReDim cmpxl3(0) As String
    ReDim cmpxl4(0) As String
    n = 0
    For i = 20 To lastrow
        If xlSheet.Cells(i, 2) <> "" Then
            n = n + 1
            ReDim Preserve cmpxl2(n) As String
            ReDim Preserve cmpxl3(n) As String
            ReDim Preserve cmpxl4(n) As String

            cmpxl2(n) = xlSheet.Cells(i, 2) & " " & Format(i)
            cmpxl3(n) = xlSheet.Cells(i, 3)
            cmpxl4(n) = xlSheet.Cells(i, 4)
        End If
    Next i
    n1records = Adodc1.Recordset.RecordCount

    'If n > n1records Then 'it's been deleted from sql so find the part and add to xl revision sheet
        n1 = 0
        ReDim cmpsql2(n1records) As String
        With Adodc1.Recordset
           For i = 1 To n1records
               If i = 1 Then
                   Adodc1.Recordset.MoveFirst
               Else
                   Adodc1.Recordset.MoveNext
               End If
               cmpsql2(i) = !pcno
           Next i
        End With
        For i = 1 To n
            bFound = qpa.Find(cmpsql2(), Left$(cmpxl2(i), 4), Found, , 1)
            If bFound = False Then
                q(1) = Val(Mid$(cmpxl2(i), 6))
                n1 = n1 + 1
                ReDim Preserve deletedfromsql(3, n1)
                deletedfromsql(1, n1) = xlSheet.Cells(q(1), 2)
                deletedfromsql(2, n1) = xlSheet.Cells(q(1), 3)
                deletedfromsql(3, n1) = xlSheet.Cells(q(1), 4)

            End If

        Next i

    'End If

    n = 0
    Do
        n = n + 1
        If xlsheet2.Cells(n + 13, 1) > "   " Then
            ReDim Preserve rev(10, n)
            ReDim Preserve part(n)
            'part(n) = xlSheet.Cells(n + 13, 3) & "*" & xlSheet.Cells(n + 13, 1)
            If xlsheet2.Cells(n + 13,  > CDate(lastrevdate) Then
                lastrevdate = xlsheet2.Cells(n + 13, 8-)
            End If
            For i = 1 To 10
                rev(i, n) = xlsheet2.Cells(n + 13, i)
            Next i
        Else
            Exit Do
        End If
    Loop
    If engr = "" Then
        engr = xlSheet.Cells(14, 2)
        chcked = xlSheet.Cells(14, 3)
    End If
Else
    mbomflag = 0
    revlev = 0
    If engr = "" Then
        engr = UCase$(InputBox("Enter Mechanical drafter's Initials:", "Enter Initials"))
        'If engr = "" Then Exit Sub
        chcked = UCase$(InputBox("Enter Checker's Initials:", "Enter Initials"))
        'If chcked = "" Then Exit Sub
    End If
End If

'Set xlBook = GetObject(path(2) & "vb\sql\ebomtemplate.xls")
Set xlBook = GetObject(Defaults.ApplicationPath & "\mbomTemplate.xls")
Set xlSheet = xlBook.Worksheets(1)
Set xlsheet2 = xlBook.Worksheets(2)



If revlev = 0 Then
    xlsheet2.Cells(14, 8= Date
End If
'xlSheet.PageSetup.Zoom = 50
If UBound(rev, 2) > 0 Then
    lastrevrow = UBound(rev, 2) + 13
    For i = 14 To UBound(rev, 2) + 13
        For j = 1 To 10
            xlsheet2.Cells(i, j) = rev(j, i - 13)
        Next j
    Next i
Else
    lastrevrow = 13
End If


'If uprev = 1 Then

'    xlBook.Application.Visible = True
'    xlBook.Parent.Windows(2).Visible = True
'    xlBook.Parent.Windows(2).Activate
'    xlSheet.Activate
    'bFound = bringwindowtotop(hwnd)
    'xlBook.Sheets(1).Select
    'ActiveSheet.Visible = True
    'xlBook.Application.DoubleClick
'Else
    xlBook.Application.Visible = True
    xlBook.Parent.Windows(1).Visible = True
    xlBook.Parent.Windows(1).Activate
    xlSheet.Activate
    'DetectExcel
    'bFound = bringwindowtotop(hwnd)

'End If

'DetectVB
'Found = apiShowWindow(hwnd, SW_SHOWMINIMIZED)


'DetectExcel
'Found = apiShowWindow(hwnd, SW_SHOWMAXIMIZED)
Me.Visible = False



Screen.MousePointer = vbDefault
'If uprev = 1 Then
'    xlBook.NewWindow.Activate
'    With xlBook.NewWindow
'        .ActiveSheet = 2
'        .Zoom = 50
'    End With
'End If
'xlBook.Application.Visible = True
'xlBook.Parent.Windows(1).Visible = True
'xlSheet.Activate

'qs(1) = "03040609121314151617181920212223242526272829303132333435"


cs = UCase$(cs)
sos = UCase$(sos)

xlSheet.Cells(10, 2) = cs & Left$(sos, 5)
If Val(framestr(0, 0, 15)) < 8 Then qs(1) = "2" Else qs(1) = "4"
xlSheet.Cells(10, 3) = "-" & Mid$(sos, 6, 1) & Right$(sos, 1) & "B" & qs(1) & "004"
xlSheet.Cells(12, 2) = Right$(sos, 3)
xlSheet.Cells(10, 6) = framestr(0, 0, 3)


'xlSheet.Cells(12, 3) = "0"
'xlSheet.Cells(16, 2) = Date
'xlSheet.Cells(16, 3) = Date

xlSheet.Cells(10, 4) = framestr(0, 0, 658) 'sold to
xlSheet.Cells(11, 4) = framestr(0, 0, 657)
xlSheet.Cells(12, 4) = framestr(0, 0, 656)
xlSheet.Cells(14, 2) = engr
xlSheet.Cells(14, 3) = chcked
xlSheet.Cells(14, 4) = framestr(0, 0, 655) 'for
xlSheet.Cells(14, 6) = framestr(0, 0, 661) 'purchase order
xlSheet.Cells(15, 4) = framestr(0, 0, 654)
xlSheet.Cells(16, 4) = framestr(0, 0, 653)

xlcol = "L M N O P Q R S T U V W X Y Z AAABACADAEAFAGAHAIAJ"

qs(1) = "L12:" & Trim$(Mid$(xlcol, (nof + 1) * 2 - 1, 2)) & "16"
xlSheet.Cells.Range(qs(1)).Value = " "


For i = 1 To nof
    xlSheet.Cells(19, i + 11) = i
Next i

For i = 1 To nof + 1
    qs(1) = Trim$(Mid$(xlcol, i * 2 - 1, 2)) & "12:" & Trim$(Mid$(xlcol, i * 2 - 1, 2)) & "16"
    With xlSheet.Cells.Range(qs(1)).Borders(xlLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
Next i

qs(1) = Chr(76) & "12:" & Trim$(Mid$(xlcol, nof * 2 - 1, 2)) & "12"
With xlSheet.Cells.Range(qs(1)).Borders(xlTop)
    '.LineStyle = xlContinuous
    .Weight = xlMedium
End With

qs(1) = Chr(76) & "16:" & Trim$(Mid$(xlcol, nof * 2 - 1, 2)) & "16"
With xlSheet.Cells.Range(qs(1)).Borders(xlBottom)
    '.LineStyle = xlContinuous
    .Weight 

我知道VB 6已过时，并且不确定为什么他们不迁移到VB.NET。 如果有人可以提供帮助，我将不胜感激。 提前致谢 ：）

Answer 1

您的问题与VB6过时无关。 问题在于此代码不可运行。 我只能猜测这是基于实际运行代码的某些黑化版本。 我将根据该代码的实际外观做出一些猜测。 但是，提供实际的代码是一个好主意。

我认为“标签”是指“工作表”。 我猜它们被称为“ Sheet1”和“ Sheet2”。 因此，基本上，实际上只有“ Sheet1”被重新填充。 “ Sheet2”保持以前的样子。

我建议您将断点放在行上：

Set xlsheet2 = xlBook.Worksheets(2)

查看xlsheet2.Cells（14,8）是否计算为您期望在该工作表上看到的日期。

在完成这一行之后，请确保xlsheet2实际上指向您期望的工作表。 我还将在读取或写入xlsheet2.Cells（x，y）的每一行上都设置断点，并查看sheet2，以确保读取或写入的值正确。