简体   繁体   中英

Formula in cells missing after running VBA Macro

In the 'power' sheet under the column D,E & F there were formulas written in the cells; however, after running the following macro (I think), the aforementioned formulas vanished. How did this happen? And how can I retain the original formulas while running the macro?

Sub ReadData()

Dim i, j, k, obs, n As Integer
Dim value, sum As Double
Dim resultsExist As Boolean

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = "Read Data: Copying data"

' Copy factor values
Sheets("Power").Range("IData").Resize(maxObserv).Clear
Sheets("Data").Select
Rows("1:1").Select
i = FindColumn(Sheets("Data"), Range("Name").value)
If i = 0 Then GoTo Cleanup
Cells(1, i).Select
ActiveCell.Range("A2:A" & maxObserv).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Power").Select
Range(ValuePos).PasteSpecial xlPasteValues
Application.CutCopyMode = False

' Copy default data
Sheets("Data").Select
Range("A2:A" & maxObserv).Select
Selection.Copy
Sheets("Power").Select
Range(DefaultPos).Select
ActiveSheet.Paste
Application.CutCopyMode = False

' Copy segment data
Sheets("Data").Select
j = FindColumn(Sheets("Data"), "ID")
If j > 0 Then
ActiveSheet.Range(Cells(1, j), Cells(maxObserv, j + 3)).Select    ' Change here to adjust sample size
Selection.Copy
Sheets("Power").Select
Range(InfoPos).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If

' Sort data
Application.StatusBar = "Read Data: Sorting"
Sheets("Power").Select
Range("IData").Select
Selection.Sort Key1:=Range(ValuePos), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
obs = 1
value = -9999999
Do Until Cells(obs + 4, 2) = ""
If Cells(obs + 4, 1) <> value Then
  If (n > 1) And (sum > 0) Then
    For k = obs - n To obs - 1
      Cells(k + 4, 2) = sum / n
    Next k
  End If
  n = 1
  value = Cells(obs + 4, 1)
  sum = Cells(obs + 4, 2)
Else
  n = n + 1
  sum = sum + Cells(obs + 4, 2)
End If
obs = obs + 1
Loop

' Retrieve or calculate buckets range
Sheets("Analysis").Select
k = FindColumn(Sheets("Results"), Range("Name").value)
If (k > 0) Then resultsExist = (Sheets("Results").Cells(6, k) <> "") Else resultsExist = False
If resultsExist Then
Application.StatusBar = "Read Data: Retrieving stored results"
Range("loBucket") = Sheets("Results").Cells(11, k)
Range("hiBucket") = Sheets("Results").Cells(12, k)
Range("upperCutoff") = 2.95 / Sheets("Results").Cells(7, k) + Sheets("Results").Cells(6, k)
Range("lowerCutoff") = 2 * Sheets("Results").Cells(6, k) - Range("upperCutoff")
Else
Application.StatusBar = "Read Data: Calculating suggestions"
Calculate
Range("loBucket") = Range("minData")  ' Alternatively one could set this
Range("hiBucket") = Range("maxData")  ' to 5% and 95% percentile
Range("lowerCutoff") = Application.WorksheetFunction.Percentile(Range("Data"), 0.05)
Range("upperCutoff") = Application.WorksheetFunction.Percentile(Range("Data"), 0.95)
End If
Calculate

Cleanup:
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

New edit: sorry I've left out the option explicit part of the code, it's like this -

Option Explicit
Const maxObserv As Integer = 30000
Const ValuePos As String = "A5"
Const DefaultPos As String = "B5"
Const InfoPos As String = "C4"

New edit: FindColumn is a function defined as below -

Function FindColumn(searchSheet As Worksheet, colName As String) As Integer

Dim i As Integer

i = 2
Do While searchSheet.Cells(1, i) <> ""
    If searchSheet.Cells(1, i) = colName Then
        FindColumn = i
        Exit Do
    End If
    i = i + 1
Loop

End Function

New edit: below are the codes run before the aforementioned codes under sub "ReadData()", which might affect the result -

Sub AdjustModel()

  Dim obs As Integer
  Dim tmpRange As Range

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  ' Count number of observations in Data sheet
  Sheets("Data").Select
  obs = 1
  Do Until Cells(1 + obs, 1) = "" And Cells(2 + obs, 1) = ""
    obs = obs + 1
  Loop

  ' Adjust names to required length
  ActiveWorkbook.Names("Data").RefersTo = "=Power!$A$5:$A$" & (5 + obs)   ' factor values
  ActiveWorkbook.Names("DData").RefersTo = "=Power!$B$5:$B$" & (5 + obs)  ' default flag
  ActiveWorkbook.Names("LData").RefersTo = "=Scores!$A$5:$A$" & (5 + obs) ' logit values
  ActiveWorkbook.Names("SData").RefersTo = "=Scores!$B$5:$B$" & (5 + obs) ' factor scores
  ActiveWorkbook.Names("PData").RefersTo = "=Power!$T$5:$V$" & (5 + obs)  ' data for power calculation
  ActiveWorkbook.Names("IData").RefersTo = "=Power!$A$5:$F$" & (5 + obs)  ' information data
  Sheets("Power").Names("BData").RefersTo = "=Power!$G$5:$G$" & (5 + obs)   ' bucket number of observation
  Sheets("Scores").Names("BData").RefersTo = "=Scores!$C$5:$C$" & (5 + obs) ' bucket number of observation

  'Adjust formulas to correct length
  Sheets("Power").Range("PData").Formula = Sheets("Power").Range("PData").Rows(1).Formula
  Sheets("Power").Range("BData").Formula = Sheets("Power").Range("BData").Cells(1, 1).Formula
  Sheets("Scores").Range("BData").Formula = Sheets("Scores").Range("BData").Cells(1, 1).Formula
  Sheets("Scores").Range("LData").Formula = Sheets("Scores").Range("LData").Cells(1, 1).Formula
  Sheets("Scores").Range("SData").Formula = Sheets("Scores").Range("SData").Cells(1, 1).Formula

  ' Adjust charts
  Sheets("Analysis").ChartObjects("Chart 1").Chart.SeriesCollection(1).XValues = Range("PData").Columns(1)
  Sheets("Analysis").ChartObjects("Chart 1").Chart.SeriesCollection(1).Values = Range("PData").Columns(2)

  ' Cleanup
  Application.StatusBar = False
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

There are a few main points I just want to make about your code that should help.

  1. Avoid using .Select
  2. Always explicitly state the sheet (and workbook, if applicable) when using multiple worksheets. This can cause many headaches if you don't, especially if using .Select and are bouncing around sheets copying/pasting. This may be a reason your PasteSpecial is overwriting data you want - you don't specify the sheet it should paste over.

  3. Use Option Explicit at the top, to force you to declare all variables.

  4. The way you are declaring variables isn't doing what you think it is.

I'll start with Point 4 first. You're doing

Dim i, j, k, obs, n As Integer - I assume you wish to have i , j , k , etc. as Integers. Only n is being declared as an integer...the others are the default ( Variant ). For each variable, you need to explicitly tell VBA what type you want. So, use Dim i as Integer, j as Integer, k as Integer , etc. In my code, you'll see I'm doing Dim i&, j& , the & is shorthand for As Integer . (See this page for a few more, such as # for As Double )

Point 3 - I'm not sure where the ValuePos variable is set, so that may cause an issue with your pasting. This is where Option Explicit helps you make sure you have the variables you are trying to use.

The first and second points are contained in my code. I tried to leave your code as-is, but comment out lines you don't need, and also added a few comments of my own.

The main concern I have is that I'm not sure what sheets each range you need, so look closely and adjust as necessary.

Option Explicit

Sub ReadData()

Dim i&, j&, k&, obs&, n&
Dim value#, sum#
Dim resultsExist As Boolean

' I think you want these as ranges, but change if not.
Dim maxObserv As Range, ValuePos As Range, findColumn As Range, defaultPos As Range

Dim powerWS As Worksheet, dataWS As Worksheet, analysisWS As Worksheet, resultsWS As Worksheet
Dim infoPos As Range

Set powerWS = Sheets("Power")
Set dataWS = Sheets("Data")
Set analysisWS = Sheets("Analysis")
Set resultsWS = Sheets("Results")

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = "Read Data: Copying data"

' Copy factor values
powerWS.Range("IData").Resize(maxObserv).Clear
'Sheets("Data").Select  ' You don't need to use `.select`, you can just work directly with the data. Plus, you never do anything with this selection
' Rows("1:1").Select
i = findColumn(dataWS, Range("Name").value)

'If i = 0 Then GoTo Cleanup 'Don't use GoTo, not best practice. Instead just do the following
If i = 0 Then
    Application.CutCopyMode = False
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
End If

'Cells(1, i).Select
'ActiveCell.Range("A2:A" & maxObserv).Select
'Application.CutCopyMode = False
'Selection.Copy ' This can be replaced with the below, to avoid using .Select

' I don't know which sheet you wanted, so change the `powerWS` to whatever sheet it should be
powerWS.Cells(1, i).Copy
powerWS.Range(ValuePos).PasteSpecial xlPasteValues  ' WHERE DOES ValuePos come from???
Application.CutCopyMode = False

' Copy default data
'Sheets("Data").Select
'Range("A2:A" & maxObserv).Select
'Selection.Copy

dataWS.Range("A2:A" & maxObserv).Copy
powerWS.Range(defaultPos).Paste
Application.CutCopyMode = False

' Copy segment data

j = findColumn(dataWS, "ID")
If j > 0 Then
    With dataWS
        .Range(.Cells(1, j), .Cells(maxObserv, j + 3)).Copy    ' Change here to adjust sample size
    End With
    'Sheets("Power").Select
    powerWS.Range(infoPos).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

' Sort data
Application.StatusBar = "Read Data: Sorting"
'Sheets("Power").Select
'Range("IData").Select
powerWS.Range("IData").Sort Key1:=powerWS.Range(ValuePos), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
obs = 1
value = -9999999
Do Until powerWS.Cells(obs + 4, 2) = ""
    With powerWS
        If .Cells(obs + 4, 1) <> value Then
          If (n > 1) And (sum > 0) Then
            For k = obs - n To obs - 1
              .Cells(k + 4, 2) = sum / n
            Next k
          End If
          n = 1
          value = .Cells(obs + 4, 1)
          sum = .Cells(obs + 4, 2)
        Else
          n = n + 1
          sum = sum + .Cells(obs + 4, 2)
        End If
        obs = obs + 1
    End With
Loop

' Retrieve or calculate buckets range
'Sheets("Analysis").Selecth
With analysisWS
    k = findColumn(resultsWS, resultsWS.Range("Name").value) ' What sheet is "Name" on, I assumed the "Results" sheet
    If (k > 0) Then resultsExist = (resultsWS.Cells(6, k) <> "") Else resultsExist = False
        If resultsExist Then
        Application.StatusBar = "Read Data: Retrieving stored results"
        .Range("loBucket") = Sheets("Results").Cells(11, k)
        .Range("hiBucket") = Sheets("Results").Cells(12, k)
        .Range("upperCutoff") = 2.95 / Sheets("Results").Cells(7, k) + Sheets("Results").Cells(6, k)
        .Range("lowerCutoff") = 2 * Sheets("Results").Cells(6, k) - Range("upperCutoff")
    Else
        Application.StatusBar = "Read Data: Calculating suggestions"
        Calculate
        .Range("loBucket") = .Range("minData")  ' Alternatively one could set this
        .Range("hiBucket") = .Range("maxData")  ' to 5% and 95% percentile
        .Range("lowerCutoff") = Application.WorksheetFunction.Percentile(.Range("Data"), 0.05)
        .Range("upperCutoff") = Application.WorksheetFunction.Percentile(.Range("Data"), 0.95)
    End If
End With
Calculate

'Cleanup:
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

I hope this helps get to the bottom of it. If not, I still recommend trying to break down the removal of .Select and using the explicit sheet names/ranges. But again, if this is the only code you're using, ValuePos is empty, so when you go to paste to that range, there's ...no range? You should add some declaration for that variable.

Edit: As @vacip mentions, you can step through the macro with F8 and watch what each line does. Especially pay attention when you get to the PasteSpecial lines. It'll allow you to see where the pasting is being done, so you can tweak accordingly.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM