在我的组织中，我们有一个基于 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。如果有人能提供帮助我真的很感激。在此先感谢：）
答案 0 :(得分：0)
你的问题与VB6过时无关。问题是这段代码是不可用的。我只能猜测这是一个基于实际运行代码的黑客版本。我将根据此代码真正的大致内容进行一些猜测。但是，提供实际代码是个好主意。
通过“标签”，我认为你的意思是“工作表”。我猜它们被称为“Sheet1”和“Sheet2”。所以基本上，只有“Sheet1”实际上正在重新填充。 “Sheet2”仍然像以前一样。
我建议你在线上设一个断点：
Set xlsheet2 = xlBook.Worksheets(2)
查看xlsheet2.Cells（14,8）是否评估到您希望在该工作表上看到的日期。
单步执行此行后，请确保 xlsheet2 实际指向您期望的工作表。我还会在读取或写入xlsheet2.Cells（x，y）的每一行上设置断点来评估它，并查看sheet2，确保读取或写回的值是正确的。