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