问VBA不将值粘贴到新工作簿工作表中
EN

Stack Overflow用户

提问于 2020-09-22 16:48:16

回答 1查看 37关注 0票数 0

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

下面是我的代码：

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

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

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

有什么想法吗？

excel

vba

回答 1

Stack Overflow用户

回答已采纳

发布于 2020-09-22 17:38:01

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

其中包括一些其他修复，例如使用工作表对象限定每个范围。

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