VBA - Dynamic Cell Shifting

[4EverStudent]

Hello, all!

I've been searching all over the web to find an answer to this, but I can't seem to find anything. I hope I'm able to explain properly what I'm encountering:

I created a budgeting tool for my coworker. It consists of four sections: AR, POs, Overhead, and AP. There are 10 columns of data. The first six represent six weeks starting with the current week. Then, there's a "buffer" column followed by three other formula columns.

6/9

6/16

6/23

6/30

7/7

7/14

formula1

formula2

formula3

Every week, the first 6 columns are updated with new information. I was able to a macro for my coworker to prevent her from having to manually move and format data. It deletes last week's information, shifts the next bunch of data to the left, and creates a fresh space for new data for the following week.

6/9	6/16	6/23	6/30	7/7	7/14		formula1	formula2	formula3
$40	$50	$60	$70	$80	$90		--	--	--

Changes to:

6/16	6/23	6/30	7/7	7/14	7/21		formula1	formula2	formula3
$50	$60	$70	$80	$90			--	--	--

Originally, everything was working perfectly. I then realized we had to have the ability to add and delete rows as new projects came up and old ones closed out. In doing so, I'd have to update the code manually to make sure the right data was being shifted (for example, after adding rows, I'd need to change Range("C1:C25") to Range("C1:C26)). To make this an automated process, I named the ranges of data that had to be moved and called those named ranges in the code (For example, Range("Name")). Now, we can add and remove rows and it doesn't affect anything, as the named ranges reflect all of the information within the selected reference.

I've since run into a problem. Part of the code selects the data that is to be shifted to the left. We use the "note" feature in Excel, so simply copying the values and shifting them over doesn't work. We need to shift the actual cells. See the following:

Range("AROLD").Cut Destination:=Range("ARNEW")

This works perfectly the first time. The cells are moved, the 6th column is then freed up and formatted for use, and the rest of the code works as it should. However, the next time the sheet is updated, AROLD and ARNEW still refer to the absolute cells that had already been shifted (for example, if cells C1:F1 shifted to B1:E1, the named ranges would then try to move B1:E1 to A1:D1).

I tried to remedy this by entering code to change the references back to what they were immediately after shifting the cells, but I realized that if rows were added or deleted after the fact, that code would need to be updated manually again (as in, changing the reference back to R1C3 may not work if we've added a row and now need to reference R2C3).

Is there a way to make this dynamic? I want AROLD and ARNEW to always refer to those same cells while still allowing the addition and deletion of rows.

Please let me know if you need me to elaborate. I'm new to VBA, so the answer might be staring me in the face and I don't even know it. Here's a shortened version (for relevancy) of the code I wrote:

Sub Update_Budget()

'Range Titles
'HEADER - Headers in AR, PO, and AP
'EWRFORM - Formulas for Estimated Weekly Revenue
'AMRFORM = AR Actual Monthly Revenue
'EWPFORM = PO Estimated Weekly PO
'CADFORM = Overhead Cash Available for Disbursement
'TPOFORM = Overhead Total POs and Overhead
'ECBFORM = AP Ending Cash Balance
'EWAPFORM = Estimated Weekly AP
'ARNEW = Area for new AR entries
'AROLD = Area to be shifted over AR
'PONEW = Area for new PO entries
'POOLD = Area to be shifted over PO
'APNEW = Area for new AP entries
'APOLD = Area to be shifted over AP
'TODAY = Formula for Friday of current week =TODAY()+(6-WEEKDAY(TODAY()))
'RNGSELECT1-3 = Selection of ranges from which to offset onto column H for new week

' if then else check date
' if then statement first

If [c1] = [z1] Then GoTo MsgBox

Dim n As Long

On Error GoTo CleanExit:
Application.ScreenUpdating = False
Application.EnableEvents = False

' days since last data shift

n = [c1] - [z1]

If n <= 7 Then

' store and clear formulas for overhead to prevent ref error

' AR estimated weekly revenue

Dim r As Variant
r = Range("EWRFORM").Formula
Range("EWRFORM").ClearContents

' AR Actual Monthly Revenue

Dim m As Variant
m = Range("AMRFORM").Formula
Range("AMRFORM").ClearContents

' PO Estimated weekly PO

Dim w As Variant
w = Range("EWPFORM").Formula
Range("EWPFORM").ClearContents

' Overhead Cash Avail

Dim f As Variant
f = Range("CADFORM").Formula
Range("CADFORM").ClearContents

' Overhead Total POs and Overhead

Dim v As Variant
v = Range("TPOFORM").Formula
Range("TPOFORM").ClearContents

' AP Ending Cash Balance

Dim b As Variant
b = Range("ECBFORM").Formula
Range("ECBFORM").ClearContents

' AP Estimated Weekly AP

Dim e As Variant
e = Range("EWAPFORM").Formula
Range("EWAPFORM").ClearContents

' Shift Cells

' AR
Range("AROLD").Cut Destination:=Range("ARNEW")


' PO
Range("POOLD").Cut Destination:=Range("PONEW")


' AP
Range("APOLD").Cut Destination:=Range("APNEW")

' paste previously copied formulas for overhead

Range("EWRFORM") = r
Range("AMRFORM") = m
Range("EWPFORM") = w
Range("CADFORM") = f
Range("TPOFORM") = v
Range("ECBFORM") = b
Range("EWAPFORM") = e

'Format empty cells

Range("RNGSELECT").Offset(0, -1).Select

With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
      With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    
    
Range("RNGSELECT2").Offset(0, -1).Select

With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
      With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    
    
Range("RNGSELECT3").Offset(0, -1).Select

With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
      With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    
' store new dates

Range("c1") = Range("TODAY").Value

Else

' error message
MsgBox:

MsgBox "Already up to date"


End If

' end with first cell select to prevent having to scroll up

Range("A1").Select

Application.ScreenUpdating = True
Application.EnableEvents = True

Exit Sub

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Err.Clear
    
   
End Sub

Thank you for your time!

 

[Max1616]

If your spreadsheet is empty below the range you are trying to manipulate then use this to find a dynamic last row:

Sub DynamicRow()

Dim lrow As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row

End Sub

This will allow you to reference dynamic ranges. For example let's say you want to take all the data from C2:Fn where n is the last row of data populated. You can write something like the below, and reference rng as your range you are trying to manipulate:

Sub DynamicRange()

Dim lrow As Long
Dim rng As Range

lrow = Cells(Rows.Count, 3).End(xlUp).Row 'This caluclates the last row of data in column C. Note - The 3 represents column C.

Set rng = Range("C2:F" & lrow) 'Set your range, where lrow is the final row populated with data

rng.Copy 'Copy your dynamic range of C2:Fn
Range("B2").PasteSpecial xlPasteValues 'Paste the data, starting in cell B2

Range("F2:F" & lrow).ClearContents 'Remove data from column F (starting in row 2 to exlcude the headers)

End Sub

I hope this helps!

 

[Max1616]

Oh, one other thing, if you want to paste the notes/formatting over, then you can paste normally instead of pasting the values.

Sub DynamicRange()

Dim lrow As Long
Dim rng As Range

lrow = Cells(Rows.Count, 3).End(xlUp).Row 'This caluclates the last row of data in column C. Note - The 3 represents column C.

Set rng = Range("C2:F" & lrow) 'Set your range, where lrow is the final row populated with data

rng.Copy Range("B2") 'Cut your range and paste the data, starting in cell B2

Range("F2:F" & lrow).ClearContents 'Remove data from column F (starting in row 2 to exlcude the headers)

End Sub

Cutting would also be viable and you can remove the clearcontents line that I provided in my code.

 

[4EverStudent]

Oh, one other thing, if you want to paste the notes/formatting over, then you can paste normally instead of pasting the values.

Sub DynamicRange()

Dim lrow As Long
Dim rng As Range

lrow = Cells(Rows.Count, 3).End(xlUp).Row 'This caluclates the last row of data in column C. Note - The 3 represents column C.

Set rng = Range("C2:F" & lrow) 'Set your range, where lrow is the final row populated with data

rng.Copy Range("B2") 'Cut your range and paste the data, starting in cell B2

Range("F2:F" & lrow).ClearContents 'Remove data from column F (starting in row 2 to exlcude the headers)

End Sub

Cutting would also be viable and you can remove the clearcontents line that I provided in my code.

Thank you,

What about if the rows below the data aren't empty?

I have 4 different "tables" of information stacked vertically. Each have a buffer of about 10 +/- blank rows. Is there a way to create dynamic last rows relative to each "table?"

(I have "table" in quotes because they aren't actual Excel tables, just ranges of data set up to look like a table. )

 

[4EverStudent]

Thank you,

What about if the rows below the data aren't empty?

I have 4 different "tables" of information stacked vertically. Each have a buffer of about 10 +/- blank rows. Is there a way to create dynamic last rows relative to each "table?"

(I have "table" in quotes because they aren't actual Excel tables, just ranges of data set up to look like a table. )

Or, maybe, is there a way to set the dynamic "last row" to a named row? Can this be done with columns as well?