malik641
11-28-2005, 09:23 AM
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
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