Solved: Getting rid of old data...but keep formulas

[malik641]

Hey everyone :hi:

There are three (main) sheets and two workbooks (the two workbooks have the same sheets and formats): Forecast, Actual, and Results [one of the workbooks is the current (Bioanalytical MS) and the other holds old values (Bioanalytical MS Old Values)
They all hold dates, and the Results sheet is ONLY formulas and tell whether items are late or on time. The Actual sheet reference the Forecast sheet for columns A through F. And Forecast holds no formulas.

I have this code to export finalized values into another workbook and delete those values that have are in the current workbook (meaning in column R is a finalized date in the 'Actual' sheet). My problem is when I delete the inputted values, the formulas that reference those values (in sheets Actual and Results) become "#REF!" errors. I'm not too sure how I could export the data and delete it without losing formulas (I was trying not to do any Copy/Pasting of formulas...but if nothing else is available/faster, then it's okay as long as it's efficient).

Here is the code:
Option Explicit
Sub Export_Old_Data()
Application.ScreenUpdating = False
Dim wb As Workbook
Dim RowsToDelete() As Variant
Dim cell As Variant
Dim ArrayCount As Long
Dim LastRow As Long
Dim LastCol As Long
Dim LastRowOldSheet As Long
Dim i As Long
Dim RangeToCopy As Range
'Check to see if Workbook to transfer data is open
' If not, then open it.
If WorkbookIsOpen("Bioanalytical MS Old Values.xls") = False Then
Set wb = Workbooks.Open("Z:\~Work\~Recent Projects\Bioanalytical MS Old Values.xls")
Else
Set wb = Workbooks("Bioanalytical MS Old Values.xls")
End If
'Export the Data
'************************************************************************** ************************
'Set Initial Variables
ArrayCount = 0
LastRowOldSheet = wb.Sheets("Actual").Cells(Rows.Count, "A").End(xlUp).Row + 1
'Uses the "Actual" sheet to store the rows for the Array
With ThisWorkbook.Sheets("Actual")
LastCol = .Cells(6, Columns.Count).End(xlToLeft).Column
LastRow = .Cells(Rows.Count, LastCol).End(xlUp).Row

'Set Array list
For Each cell In Range(.Cells(7, LastCol), .Cells(LastRow, LastCol))
If cell.Value <> vbNullString Then
ReDim Preserve RowsToDelete(ArrayCount)
RowsToDelete(ArrayCount) = cell.Row
ArrayCount = ArrayCount + 1
End If
Next cell

'Export the Data from Current MS workbook to Old MS workbook
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Actual").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues
Next i
End With
'Forecast sheet Data Export
With ThisWorkbook.Sheets("Forecast")
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Forecast").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues
Next i
End With
'Results sheet Data Export
With ThisWorkbook.Sheets("Results")
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Results").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues
Next i
End With
'************************************************************************** ************************
'Remove old Data in Current MS workbook and replace lost formulas
'************************************************************************** *********
With ThisWorkbook.Sheets("Actual")
For i = ArrayCount - 1 To 0 Step -1
.Range(.Cells(RowsToDelete(i), "G"), .Cells(RowsToDelete(i), LastCol)).Delete Shift:=xlUp
Next i
End With
With ThisWorkbook.Sheets("Forecast")
For i = ArrayCount - 1 To 0 Step -1
.Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol)).Delete Shift:=xlUp
Next i
End With
'************************************************************************** *********
'Save and close workbook
'With wb
' .Save
' .Close
'End With
Application.ScreenUpdating = True
End Sub
Private Function WorkbookIsOpen(wbname) As Boolean
'Returns TRUE if the workbook is open
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function


And BTW, I noticed that the deleting portion of the code is a LOT slower than the rest of the code...is there a better/more efficient way to code it?

Thanks in advance :thumb

[mdmackillop]

Hi Joseph,
If you just need to delete the error values, the following code should do that

Selection.SpecialCells(xlCellTypeFormulas, 16).ClearContents

[malik641]

Hey Malcom,
Let me clear it up a little bit.

Sheet 'Actual':
A8=If(Forecast!A8="","",Forecast!A8)

Now lets say I use my code and there was a finalized date in 'Actual' row 8.
I only delete the values to the right of the formulas on the 'Actual' sheet (non-formulas) in row 8. In the Forecast sheet it deletes "A8:R8" and shifts cells up.

Now sheet 'Actual' cell A8 says:
A8=If(Forecast!#REF!="","",Forecast!#REF!)

when I wish it was the same.


But thanks for the code, now I know how to delete #REF! values :thumb

[Ken Puls]

Hi Joseph,

Are you just trying to clear the values out, rather than delete them? You could try:

Activecell.Clearcontents

The thing is that if you do delete a row which feeds in to a formula, you are going to get that error. I don't see any way around that.

The other alternative is to convert everything to values, then delete the rows. You lose your formulas, but the values stay intact.

HTH,

[Shazam]

If you like to retain your formula then try these formulas put them in cell A8

=IF(INDEX(Forecast!A:A,8)="","",INDEX(Forecast!A:A,8))

=IF(INDIRECT("Forecast!A8")="","",INDIRECT("Forecast!A8"))

Or if you want a formula that retain your vaules because you export your data to another workbook. Here is a sample formula you could try.

Put this formula in cell A8

=IF(ISERROR(Forecast!A8),'C:\Documents and Settings\Information System\My Documents\[Book5.xls]Forecast'!$A$8,Forecast!A8)

Or you want a relative solution then try this formula, Just put this formula in cell A1 and copy it down.

=IF(OFFSET(Forecast!A:A,Forecast!A1,,1,3)="","",OFFSET(Forecast!A:A,Forecast!A1,,1,3))

[johnske]

To clear all the data (i.e. constants) from the entire worksheet and leave the formulas intact, use...Cells.SpecialCells(xlCellTypeConstants, 23).ClearContentsThis efectively 'recycles' a worksheet for reuse with new data.

If you only want this applied to a smaller given range(s), exchange 'Cells' with the range(s) you want and this should then do what you want.

(Note that some formula may then display error values, when you insert new data these error values will go away).

[malik641]

Okay. Figured it out.

I guess I wasn't too clear on what I was asking for (exactly), but I'll try to summarize it quickly and post my code.

After I would transfer the "Finalized" data, I didn't want "holes" in my data tables. So what I had to do was to shift all the data (non-formulas) up to fill the "holes". I couldn't just "Delete Shift:xlUp" because any formula that referenced that particular Range would become a #Ref! error, so I needed another way.

Shazam,
Thanks for the formulas. Those would allow me to use the "Delete Shift:=xlUp" method. The only problem with this is that I didn't want to make my formulas longer than they already are (on the Performance sheet they are pretty long). But I will definitely be using those next time.

Malcom and Jonske,
Thanks for the Special cells method. I did some research on them and I will be using them in the future as well.


And thanks Ken for the suggestion. I appreciate the help :thumb

Here's what I end up with. Like I said, both workbooks are setup the same. I will be adding other features to this, but the code I'm displaying is the most relevant to the post.

What the code does is it copies and pastes the "finalized" values into the other workbook. Then it clears (not deletes) the data that is "finalized" (data only, non-formulas). Then it uses the array that found all the rows that were "finalized" to mark (from the bottom of the data) where to stop to copy the data range...example:

Row 107 is cleared, but the bottom of the data is in row 204. so the range would be from row 108 to row 204 (columns depend on which sheet [Forecast or actual] because Forecast doesn't have formulas and Actual does [from column A to F]...you'll see what I mean when you read the code). It copies the data and moves into the cleared row and pastes the data.

It repeats this untill all the rows in the array are used up. There is a counter to clear excess data left below the copied data (because of the copy/paste method).

And that's it (sorry for the lengthy thread :) )

If anyone sees any way to modify this code for efficiency please let me know. I'm sorry I can't post a dummy workbook right now because I'm at work and I'm using Windows 2000 and I don't have WinZip.

Here's the code:
Option Explicit
Sub Export_Old_Data()
Application.ScreenUpdating = False
Dim wb As Workbook
Dim RowsToDelete() As Variant
Dim Cell As Variant
Dim ArrayCount As Long
Dim LastRow As Long
Dim LastCol As Long
Dim LastRowOldSheet As Long
Dim i As Long 'Used to step through RowsToDelete() array
Dim j As Long 'Used to count amount of deleted rows
Dim RangeToCopy As Range 'Range that has all finished data in it
Dim RangeToMove As Range 'Used to shift all data up in "Actual" and "Forecast" sheets
Dim rFoundCell As Range 'Used to find last "Value" (not formula) used in sheet "Actual"
'Check to see if Workbook to transfer data is open
' If not, then open it.
If WorkbookIsOpen("Bioanalytical MS Old Values.xls") = False Then
Set wb = Workbooks.Open("Z:\~Work\~Recent Projects\Bioanalytical MS Old Values.xls")
Else
Set wb = Workbooks("Bioanalytical MS Old Values.xls")
End If
'Export the Data
'************************************************************************** ************************
'Set Initial Variables
ArrayCount = 0
j = 0
LastRowOldSheet = wb.Sheets("Actual").Cells(Rows.Count, "A").End(xlUp).Row + 1
'Uses the "Actual" sheet to store the rows for the Array
With ThisWorkbook.Sheets("Actual")
LastCol = .Cells(6, Columns.Count).End(xlToLeft).Column
LastRow = .Cells(Rows.Count, LastCol).End(xlUp).Row

'Set range for last row used in "Actual" sheet (for later use in macro)
Set rFoundCell = .Range("A1")
Set rFoundCell = Columns(1).Find(What:="*", After:=rFoundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False)

'Set Array list
For Each Cell In Range(.Cells(7, LastCol), .Cells(LastRow, LastCol))
If Cell.Value <> vbNullString Then
ReDim Preserve RowsToDelete(ArrayCount)
RowsToDelete(ArrayCount) = Cell.Row
ArrayCount = ArrayCount + 1
End If
Next Cell

'Results sheet Data Export
With ThisWorkbook.Sheets("Results")
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Results").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues
Next i
End With

'Export the Data from Current MS workbook to Old MS workbook and clear old data
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Actual").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues

With .Range(.Cells(RowsToDelete(i), "G"), .Cells(RowsToDelete(i), LastCol))
.ClearContents
.ClearComments
End With
Next i
End With
'Forecast sheet Data Export and clear old data
With ThisWorkbook.Sheets("Forecast")
For i = 0 To ArrayCount - 1 Step 1
Set RangeToCopy = .Range(.Cells(RowsToDelete(i), "A"), .Cells(RowsToDelete(i), LastCol))
RangeToCopy.Copy
wb.Sheets("Forecast").Cells(LastRowOldSheet + i, "A").PasteSpecial xlValues

With RangeToCopy
.ClearContents
.ClearComments
End With

Next i
End With
'************************************************************************** ************************
'Remove old Data in Current MS workbook and replace lost formulas
'************************************************************************** *********
Application.EnableEvents = False
With ThisWorkbook.Sheets("Actual")
For i = ArrayCount - 1 To 0 Step -1
Set RangeToMove = .Range(.Cells(RowsToDelete(i) + 1, "G"), .Cells(rFoundCell.Row, LastCol))

If Application.WorksheetFunction.CountA(RangeToMove) <> 0 Then
RangeToMove.Copy
ThisWorkbook.Sheets("Actual").Range("G" & RowsToDelete(i)).PasteSpecial xlAll
j = j + 1
End If
Next i

j = j - 1

'Delete excess data lying under the new table (because of the copy and paste method, there _
is extra data to be removed.)
With .Range(.Cells(rFoundCell.Row - j, "G"), .Cells(rFoundCell.Row, LastCol))
.ClearContents
.ClearComments
End With
End With
With ThisWorkbook.Sheets("Forecast")
For i = ArrayCount - 1 To 0 Step -1
Set RangeToMove = .Range(.Cells(RowsToDelete(i) + 1, "A"), .Cells(rFoundCell.Row, LastCol))

If Application.WorksheetFunction.CountA(RangeToMove) <> 0 Then
RangeToMove.Copy
ThisWorkbook.Sheets("Forecast").Range("A" & RowsToDelete(i)).PasteSpecial xlAll
End If
Next i

'Delete excess data lying under the new table (because of the copy and paste method, there _
is extra data to be removed.)
With .Range(.Cells(rFoundCell.Row - j, "A"), .Cells(rFoundCell.Row, LastCol))
.ClearContents
.ClearComments
End With
End With
Application.EnableEvents = True
'************************************************************************** *********
'Save and close workbook
'With wb
' .Save
' .Close
'End With
Application.ScreenUpdating = True
End Sub
Private Function WorkbookIsOpen(wbname As String) As Boolean
'Returns TRUE if the workbook is open
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function


Thanks again :thumb

[Zack Barresse]

We can shorten this ...

Private Function WorkbookIsOpen(wbname As String) As Boolean
'Returns TRUE if the workbook is open
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function

.. to this ..

Private Function WorkbookIsOpen(wbname As String) As Boolean
On Error Resume Next
WorkbookIsOpen = Len(Workbooks(wbname).Name)
End Function

[malik641]

We can shorten this ...

Private Function WorkbookIsOpen(wbname As String) As Boolean
'Returns TRUE if the workbook is open
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function

.. to this ..

Private Function WorkbookIsOpen(wbname As String) As Boolean
On Error Resume Next
WorkbookIsOpen = Len(Workbooks(wbname).Name)
End Function
Thanks Zack :thumb