我一直忙于创建用于在新工作簿中对数据库进行排序的代码。 此工作簿的Sheet2需要作为“Sheet2.prn”保存在工作簿旁边。我设法做到了这一点，但今天我需要向Sheet2添加2列，现在由于某种原因，将文件重新保存为.prn的最后一步不再起作用。我真的不知道我做错了什么，因为我很确定我没有改变我的代码的最后部分。
这是我的代码：
Option Explicit
Sub RowCount()
Dim Oldstatusbar As Boolean
Dim DOF As Integer, Counter As Integer
Dim CurrentMin As Long, StartRow As Long, StartColumn As Long
Dim OutputColumn As Long, OutputRow As Long, InputValue As Long
Dim Borehole As String, Start_Row As String, End_Row As String, Output As String, FolderPath As String
Dim CurrentName As String
Dim rng As RANGE, Cell As RANGE, brh As RANGE, Undef1 As RANGE, Undef2 As RANGE
Dim r1 As RANGE, r2 As RANGE, r3 As RANGE, r4 As RANGE, r5 As RANGE, r6 As RANGE, r7 As RANGE, r8 As RANGE, r9 As RANGE
Dim r10 As RANGE, r11 As RANGE, r12 As RANGE, r13 As RANGE
Dim wbMain As Workbook, wbWellsRowCount As Workbook
Dim wsLog As Worksheet, wsSheet1 As Worksheet, wsSheet2 As Worksheet
Dim HCdatabase2 As Variant
Oldstatusbar = Application.DisplayStatusBar
Set wbMain = Workbooks("HCdatabase2.xlsm")
Set wsLog = wbMain.Sheets("Log")
FolderPath = ThisWorkbook.Path
DOF = 1
Counter = 1
wsLog.Select
StartColumn = 1
StartRow = 1
wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown).Select
Set rng = wsLog.RANGE(wsLog.Cells(StartRow + DOF, StartColumn), wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown))
CurrentName = wsLog.Cells(StartRow + DOF, StartColumn).Value
CurrentMin = Cells(StartRow + DOF, StartColumn).Row
Set wbWellsRowCount = Workbooks.Add
wbWellsRowCount.SaveAs FolderPath & "\wbWellsRowCount.xls"
Set wsSheet1 = wbWellsRowCount.Sheets("Sheet1")
wsSheet1.Select
OutputColumn = 1
OutputRow = DOF + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(1, 1).Name = "Borehole"
wsSheet1.Cells(1, 2).Name = "Start_Row"
wsSheet1.Cells(1, 3).Name = "End_Row"
wsSheet1.Cells(1, 4).Name = "Output"
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Set wsSheet2 = wbWellsRowCount.Sheets("Sheet2")
Set r1 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("A:A")
Set r2 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("A:A")
Set r3 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("J:J")
Set r4 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("B:B")
Set r5 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("M:M")
Set r6 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("C:C")
Set r7 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AC:AC")
Set r8 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("D:D")
Set r9 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AF:AF")
Set r10 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("E:E")
Set r11 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("D:D")
Set r12 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("F:F")
Set r13 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("G:G")
r1.Copy r2
r3.Copy r4
r5.Copy
r6.PasteSpecial Paste:=xlPasteValues
r7.Copy r8
r9.Copy
r10.PasteSpecial Paste:=xlPasteValues
r11.Copy r12
r11.Copy r13
Application.CutCopyMode = False
With wbWellsRowCount.Sheets("Sheet2")
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp))
.Offset(.Rows.Count).Value = .Value
.Offset(.Rows.Count, 1).Value = .Offset(, 3).Value
.Offset(.Rows.Count, 4).Value = .Offset(, 4).Value
.Offset(.Rows.Count, 5).Value = .Offset(, 5).Value
.Offset(.Rows.Count, 6).Value = .Offset(, 6).Value
.Offset(, 4).ClearContents
.Offset(, 3).EntireColumn.Delete
With .Offset(, 1).Resize(2 * .Rows.Count)
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete
End With
End With
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7)
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
End With
End With
Set Undef1 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").UsedRange
On Error Resume Next
InputValue = -999
For Each Cell In Undef1
If IsEmpty(Cell) Then
Cell.Value = InputValue
End If
Next
On Error Resume Next
For Each Cell In r12
If (Cell) Then
Cell.Value = Left(Cell.Value, 2)
End If
Next
Columns("A:F").HorizontalAlignment = xlRight
Columns("A:F").AutoFit
Columns("E").ColumnWidth = 9
For Each Cell In rng
If Cell.Value <> CurrentName Then
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row - 1
CurrentName = Cell.Value
CurrentMin = Cell.Row
OutputRow = OutputRow + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
Counter = Counter + 1
End If
Next Cell
Set Cell = rng.End(xlDown)
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
wbWellsRowCount.Close True
wbWellsRowCount.Open
'wbWellsRowCount.Open FolderPath & "\wbWellsRowCount.xls"
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True
wbMain.Activate
RANGE("A1").Select
ActiveWindow.ScrollRow = RANGE("A1").Row
Application.ScreenUpdating = True
Application.DisplayStatusBar = Oldstatusbar
End Sub
我尝试了第二个（之前工作正常）和第三个规则，但由于某种原因文件没有重新打开。 具体来说，我希望保存工作簿“wbWellsRowCount”然后重新打开，以便我可以将SpaceAs另存为空格分隔文本文件。
任何人都可以帮我吗？
答案 0 :(得分：0)
因为工作簿已经打开。关闭它并重新打开它没有任何意义，这样做是昂贵/耗时的，并没有真正的目的，我可以看到。
此外，您无法通过这种方式执行此操作，因为一旦您执行.Close True，该对象将无法再使用.Open方法，如果不是你的On Error Resume Next，这一行肯定会引发错误（91：对象变量或未设置块）。
摆脱：
wbWellsRowCount.Close True '### DELETE THIS LINE
wbWellsRowCount.Open '### DELETE THIS LINE
这样你就离开了：
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True