無法使用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，以確保讀取或寫入的值正確。