Dear Don Guillet, David Smart and Derek Turner,
Thank you very much for your ideas, its really helpfull.
Based on your suggestions, finally, I could figure my code, and it's work for my xls data. The modified code is as follow :
Dim strDocPath As String
Dim strCurrentFile As String
Dim Fname As String
Application.ScreenUpdating = False
Dim LastRow1 As Long
Dim LastRow As Long,sFormula As String
LastRow1 = Range("I3").End(xlDown).Row
nLastRow = Range("I2").End(xlDown).Row
strDocPath = "D:\workfolder\hycom_be_daily\se_project\exploration_t_s_u\be_se2004_2006_19oct2012\be_se2007_validation\tes\"
strCurrentFile = Dir(strDocPath & "*.xls")
Do While strCurrentFile <> ""
Workbooks.Open Filename:=strDocPath & strCurrentFile
Range("I2").FormulaR1C1 = "=RC[-1]^2"
Range("I2").Copy Range("I3:I" & LastRow1)
sFormula = "=RSQ(i2:i" & nLastRow & ",d2:d" & nLastRow & ")"
Debug.Print sFormula
Range("j2").Formula = sFormula
ActiveWorkbook.Save
ActiveWorkbook.Close
strCurrentFile = Dir
Loop
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Close
strCurrentFile = Dir
Loop
Application.ScreenUpdating = True
Indeed, I still use two kind of lastrow. First lastrow for copy cell I2 and paste to I3 until lastrow of I, and another lastrow was used for RSQ formula.
Regards
Ed
--- On Wed, 10/24/12, Derek Turner <g4swy@yahoo.com> wrote:
From: Derek Turner <g4swy@yahoo.com>
Subject: Re: [ExcelVBA] RSQ calculation using VBA
To: "ExcelVBA@yahoogroups.com" <ExcelVBA@yahoogroups.com>
Date: Wednesday, October 24, 2012, 12:51 PM
Dear Ed
Addressing only the RSQ formula :-
Dim nLastRow As Long, sFormula As String
nLastRow = Range("I2").End(xlDown).Row
sFormula = "=RSQ(i2:i" & nLastRow & ",d2:d" & nLastRow & ")"
Debug.Print sFormula
Range("j2").Formula = sFormula
Note how you use the Debug.Print to view the formula in the Immediate window.
Why three Lastrows in your code ?
Regards
Derek Turner
+++
>________________________________
> From: dguillett1 <dguillett1@gmail.com>
>To: ExcelVBA@yahoogroups.com
>Sent: Wednesday, 24 October 2012, 13:24
>Subject: Re: [ExcelVBA] RSQ calculation using VBA
>
>
>
>I'm assuming you have no problem opening the file(s) desired despite the overly long name.....
>There are several ways to do formulas
>Sub DoFormulasSAS()
>Dim i As Long
>
>'=IF(B2="","",SUMPRODUCT((ISNUBER(SEARCH($B2,Source!$A$3:$A$200)))*1))
>'converting the spreadsheet formula to vba and leaving the value only
>
>For i = 2 To 9
>Cells(i, "e").Value = Evaluate("=IF(c" & i & "="""","""",SUMPRODUCT((ISNUMBER(SEARCH(B" & i & ",Source!$A$3:$A$200)))*1))")
>Next i
>
>With Range("d2:d40")
>.Formula = "=IF(c2="""","""",SUMPRODUCT((ISNUMBER(SEARCH($c2,Source!$A$3:$A$200)))*1))"
>'.Value = .Value
>End With
>End Sub
>=======
>Also you need to remove selections,, However, use above ideas. If all else fails, send me the file with explanations and examples.
>Range("I2").FormulaR1C1 = "=RC[-1]^2"
>Range("I2").Copy Range("I3:I" & LastRow1)
>
>'--------------------
>Don Guillett
>Microsoft Excel Developer
>SalesAid Software
>dguillett1@gmail.com
>
>From: edo rs
>Sent: Tuesday, October 23, 2012 11:48 PM
>To: ExcelVBA@yahoogroups.com
>Subject: [ExcelVBA] RSQ calculation using VBA
>
>Dear Excel VBA experts,
>
>I had tried to modified a vba script for processing my multiple xls files. I wish I can get enlightenment through this forum.
>
>My multiple xls files has different amount of row. The example of file as below :
>
>A B C D E F G H
>-12 114 3 0.2 1 0.1 0.4 0.5
>-13 112 4 0.6 1 0.1 0.4 0.8
>
>I would like to square of H and put the results on I. So the expected output is :
>
>A B C D E F G H I
>-12 114 3 0.2 1 0.1 0.4 0.5 0.25
>-13 112 4 0.6 1 0.1 0.4 0.8 0.64
>
>The next step, I would like to calculate Rsquare using formula RSQ=(I2:I3,D2:D3), and put the RSQ results on cell J2. I had tried to modified a vba script, but the result is not good as expected. Below is my modified script:
>
>Dim strDocPath As String
>Dim strCurrentFile As String
>Dim Fname As String
>Application.ScreenUpdating = False
>Dim LastRow1 As Long
>Dim LastRow2 As Long
>Dim LastRow3 As Long
>
>LastRow1 = Range("I3").End(xlDown).Row
>LastRow2 = Range("I2").End(xlDown).Row
>LastRow3 = Range("D2").End(xlDown).Row
>Set vX = Range("I2:I" & LastRow2)
>Set vY = Range("D2:D" & LastRow3)
>
>strDocPath = "D:\workfolder\hycom_be_daily\se_project\exploration_t_s_u\be_se2004_2006_19oct2012\be_se2007_validation\tes\"
>'strCurrentFile = Dir(strDocPath & "*.*")
>strCurrentFile = Dir(strDocPath & "*.xls")
>
>Do While strCurrentFile <> ""
>Workbooks.Open Filename:=strDocPath & strCurrentFile
>Range("I2").Select
>ActiveCell.FormulaR1C1 = "=RC[-1]^2"
>Range("I2").Select
>Selection.Copy
>Range("I3:I" & LastRow1).Select
>ActiveSheet.Paste
>Range("J2").Select
>Application.CutCopyMode = False
>'ActiveCell.FormulaR1C1 = "=RSQ(vX, vY)"
>Application.WorksheetFunction.RSq(vX, vY)
>ActiveWorkbook.Save
>ActiveWorkbook.Close
>strCurrentFile = Dir
>Loop
>Application.ScreenUpdating = True
>
>Your help is really appreciated
>
>Regards
>Ed
>
>[Non-text portions of this message have been removed]
>
>[Non-text portions of this message have been removed]
>
>
>
>
>
[Non-text portions of this message have been removed]
[Non-text portions of this message have been removed]
| Reply via web post | Reply to sender | Reply to group | Start a New Topic | Messages in this topic (5) |
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar