VBA未将值粘贴到新工作簿工作表中

Question

我创建了这个脚本，它将条件格式应用于三个数据透视表，并试图将每个表的结果保存到新工作簿中自己的选项卡中。

这是我的代码：

Sub conditional_formatting():
' Set dimensions
Dim i As Long
Dim rowCount As Long
Dim numOpen As Range
Dim Ws As Worksheet
Dim xWs1, xWs2, xWs3 As Worksheet
Dim NewBook As Workbook
Dim Nbs1, Nbs2, Nbs3 As Worksheet

Set NewBook = Workbooks.Add
With NewBook
Set Nbs1 = NewBook.Sheets("Sheet1")
NewBook.Sheets.Add.Name = "Sheet2"
Set Nbs2 = NewBook.Sheets("Sheet2")
NewBook.Sheets.Add.Name = "Sheet3"
Set Nbs3 = NewBook.Sheets("Sheet3")
End With
' loop through final report sheets
For Each Ws In ActiveWorkbook.Worksheets

' only loop through lic, loss loc, and reallocate reports
If Ws.Index > 4 And Ws.Index < 8 Then

If Ws.Index = 5 Then

' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row

For i = 14 To rowCount

' Store number of weeks open in working cell
Set numOpen = Range("L" & i)

' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select

Next i

Ws.Range("A13:" & "L" & rowCount).Copy
Nbs1.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs1.Name = "(lic)"

ElseIf Ws.Index = 6 Then

' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row

For i = 11 To rowCount

' Store number of weeks open in working cell
Set numOpen = Range("L" & i)

' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select

Next i

Ws.Range("A10:" & "L" & rowCount).Copy
Nbs2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs2.Name = "(loss loc)"

Else

' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row

For i = 13 To rowCount

' Store number of weeks open in working cell
Set numOpen = Range("L" & i)

' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select

Next i
Ws.Range("A12:" & "L" & rowCount).Copy
Nbs3.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs3.Name = "(reallocate)"

End If
End If

Next Ws

NewBook.SaveAs Filename:="C:Test1"
MsgBox ("Done")

End Sub

该脚本没有给我任何错误，它成功地应用了条件格式，除了创建正确的选项卡外，还重命名了它们。

出于某种原因，它实际上并没有在新工作簿中粘贴任何值。

有什么想法吗？

Answer 1

我会尝试将公共代码提取到单独的子中。

还包括一些其他修复程序，例如使用工作表对象限定每个区域。

Sub conditional_formatting():
' Set dimensions
Dim rowCount As Long
Dim Ws As Worksheet
Dim NewBook As Workbook
Dim Nbs1 As Worksheet, Nbs2 As Worksheet, Nbs3 As Worksheet
Dim wbSrc As Workbook

Set wbSrc = ActiveWorkbook '<<<<remember this workbook

Set NewBook = Workbooks.Add
With NewBook
Set Nbs1 = .Sheets("Sheet1")
.Sheets.Add.Name = "Sheet2" '<< use your With here...
Set Nbs2 = .Sheets("Sheet2")
.Sheets.Add.Name = "Sheet3"
Set Nbs3 = .Sheets("Sheet3")
End With
' loop through final report sheets
For Each Ws In wbSrc.Worksheets

rowCount = Ws.Cells(Ws.Rows.Count, "L").End(xlUp).Row 'only need this once

If Ws.Index = 5 Then
FormatRange Ws.Range("L14:L" & rowCount)
CopyValues Ws.Range("A13:L" & rowCount), Nbs1.Range("A1")
Nbs1.Name = "(lic)"
ElseIf Ws.Index = 6 Then
FormatRange Ws.Range("L11:L" & rowCount)
CopyValues Ws.Range("A10:L" & rowCount), Nbs2.Range("A1")
Nbs2.Name = "(loss loc)"
ElseIf Ws.Index = 7 Then
FormatRange Ws.Range("L13:L" & rowCount)
CopyValues Ws.Range("A12:L" & rowCount), Nbs3.Range("A1")
Nbs3.Name = "(reallocate)"
End If

Next Ws
NewBook.SaveAs Filename:="C:Test1"
MsgBox ("Done")

End Sub
'copy values from rngFrom into rngTo (resizing as necessary)
Sub CopyValues(rngFrom As Range, rngTo As Range)
With rngFrom
rngTo.Cells(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End Sub
'loop over and format a range according to cell values
Sub FormatRange(rng As Range)
Dim c As Range
For Each c In rng.Cells
Select Case c.Value
Case Is > 4
c.Interior.ColorIndex = 3
Case Is > 2
c.Interior.ColorIndex = 44
Case Else
c.Interior.ColorIndex = 43
End Select
Next c
End Sub