Incorrect Dynamic Range in Excel VBA Macro

Viewed 109

I have the following code in a macro to copy the contents of C2 and D2 cells of the active worksheet and copy it down to the last row of the table.

  1  Range("C:D").Insert Shift:=xlToRight
  2  Range("C2").FormulaR1C1 = "=RIGHT(RC[2],4)"
  3  Range("D2").FormulaR1C1 = "=LEFT(RC[1],LEN(RC[1])-5)"
                
  4  lastrow = Range("A" & Rows.Count).End(xlUp).Row
  5  Range("C2").Copy Range("C2:C" & lastrow)
  6  lastrow = Range("B" & Rows.Count).End(xlUp).Row
  7  Range("D2").Copy Range("D2:D" & lastrow)

I've been using this code for nearly 3 years now for my daily work but i just suddenly came across a file in which the dynamic range is not selected correctly at line 4 and 6. The sheet has around 30k lines but the formula only copies to the first 284 lines in both column C and D.

I first thought i was referring to a wrong sheet so i tried "lastrow = Activesheet.Range("A" & Rows.Count).End(xlUp).Row"as well as lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Rowto the same result.

Anyone can help me figure this out? I'm a bit rusty since it's been a while since i looked at anything remotely related to code...

(Can provide the file if needed)


Sub SSFormula()
    
    Application.ScreenUpdating = False
    
    Dim strPath As String
    Dim lastcol%, dest As Range, lastrow%, pt As PivotTable
    Dim iCol As Long
    Dim iColEnd As Long
    Dim strFileName As String
    Dim strFileNameTemp As String
    

    Application.DisplayAlerts = False
    strFileNameTemp = Environ("USERPROFILE") & "\Desktop\SHELFSTOCK\" & Format(Now(), "DD-MMM-YYYY - hh mmAMPM") & " SHELFSTOCK" & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=strFileNameTemp, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.Workbooks.Open (strFileNameTemp)
    

    On Error Resume Next
       For x = 1 To 200
        If Not Range("a1").Offset(0, x).IsEmpty(ActiveCell.Value) Then Range("A:A").Offset(0, x).TextToColumns Destination:=Range("A1").Offset(0, x), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
       Next x
    

        Range("C:D").Delete Shift:=xlToLeft
        

        lastrow = Sheets("Group_PositionList").Range("a" & Rows.Count).End(xlUp).Row
        lastcol = Sheets("Group_PositionList").Cells(lastrow, Columns.Count).End(xlToLeft).Column

        Sheets.Add
        Set dest = Sheets("sheet1").[A1]
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Group_PositionList!R1C1:R" & lastrow & "C" & _
        lastcol, Version:=6).CreatePivotTable TableDestination:=dest, TableName:="PivotTable2", DefaultVersion:=6
        Set pt = Sheets("sheet1").PivotTables("PivotTable2")


        With ActiveSheet.PivotTables("PivotTable2").PivotFields("Product_ID")
            .Orientation = xlRowField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("PivotTable2").PivotFields("Name")
            .Orientation = xlRowField
            .Position = 2
        End With
        
    
        ActiveSheet.PivotTables("PivotTable2").RowAxisLayout xlTabularRow
        ActiveSheet.PivotTables("PivotTable2").RepeatAllLabels xlRepeatLabels
        With ActiveSheet.PivotTables("PivotTable2")
            .ColumnGrand = False
            .RowGrand = False
        End With
        
        Set pt = ActiveSheet.PivotTables(1)

            With pt
            For Each pf In .PivotFields
            pf.Subtotals(1) = True
            pf.Subtotals(1) = False
            Next pf
        End With
    
        
        Set pt = ActiveSheet.PivotTables(1)

        With pt
       iCol = 1
       iColEnd = .PivotFields.Count

        For iCol = 1 To iColEnd
            With .PivotFields(iCol)
              If .Orientation = 0 Then
                  .Orientation = xlDataField
              End If
            End With
        Next iCol
        End With
        

        With ActiveSheet.PivotTable
        .ManualUpdate = True
        For Each pf In .DataFields
        With pf
        .Function = xlSum
        .NumberFormat = "#,##0"
        End With
        Next pf
        .ManualUpdate = False
        End With
        
        
         With ActiveSheet.PivotTables("PivotTable2").DataPivotField
            .Orientation = xlRowField
            .Position = 3
        End With
        
        pt.TableRange1.Copy
        Sheets.Add
        Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Cells.Columns.AutoFit
        
        
            Cells.Replace What:="sum of ", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Cells.Replace What:=".pln", Replacement:="", LookAt:=xlPart, SearchOrder _
            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
        .Range("C:D").Insert Shift:=xlToRight
        .Range("C2:C" & lRow).Formula = "=RIGHT(E2,4)"
        .Range("D2:D" & lRow).Formula = "=LEFT(E2,LEN(E2)-5)"

        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
        Range("E:E").Delete Shift:=xlToLeft
        
        Range("C1").FormulaR1C1 = "OUTLET"
        Range("D1").FormulaR1C1 = "DISPLAY CATEGORY"
        Range("E1").FormulaR1C1 = "SHELF STOCK"
        Cells.Columns.AutoFit
        
        Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
        On Error GoTo Next_Block:
        Range("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            
Next_Block:
        Rows("1:1").AutoFilter
        Cells.Columns.AutoFit
            
        Sheets("Sheet2").Name = "Position_by_Fixture"
        Application.DisplayAlerts = False
        Sheets("Sheet1").Delete
        Sheets("Group_PositionList").Delete
        Application.DisplayAlerts = True
    
        Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
                
        Application.DisplayAlerts = False
        strFileName = Environ("USERPROFILE") & "\Desktop\SHELFSTOCK\" & Range("'Position_by_Fixture'!D2").Text & " SHELFSTOCK" & ".xlsx"
        ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        
        Kill (strFileNameTemp)
        Application.ScreenUpdating = True
    End Sub
1 Answers

As suggested in the comments above, try this code (UNTESTED)

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        .AutoFilterMode = False
        
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        .Range("C:D").Insert Shift:=xlToRight
        .Range("C2:C" & lRow).Formula = "=RIGHT(E2,4)"
        .Range("D2:D" & lRow).Formula = "=LEFT(E2,LEN(E2)-5)"
    End With
End Sub
Related