View Full Version : Help with VBA coding
yitm03
03-14-2018, 11:55 AM
Hi there, Stuck with an issue for over a week and need someone to point me in the right direction. I recorded a macro to do a advanced filter and copy the data to another sheet. Works great with one drawback! I have over 3000 rows and created Do While Loop to get the values into 2 different columns but the macro had a fixed range from doing it manually and obviously it just creates 3000 sheets with the same value.
Sub calcModO()
Dim row As Integer
row = 2
Do While Cells(row, 6) <> ""
Cells(row, 7).Value = Cells(row, 9).Value * 0.85
Cells(row, 8).Value = Cells(row, 9).Value * 1.15
Sheets.Add After:=ActiveSheet
Range("A1").Select
Sheets("sheet1").Range("A1:AF1262").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("DIA (4)").Range("G2:H2"), CopyToRange:=Range( _
"A1"), Unique:=False
row = row + 1
Loop
End Sub
How can I, in the loop have the CriteriaRange:=Sheets("sheet1").Range("G2:H2"), change to the next row ("G3:H3")? Do I need to call on a procedure or can it be done within the code above?
Thanks for any much needed hep.
MINCUS1308
03-14-2018, 12:10 PM
loop through your data changing the values
MyRow = 2
Do While Cells(row, 6) <> ""
Cells(MyRow, 7).Value = Cells(MyRow, 9).Value * 0.85
Cells(MyRow, 8).Value = Cells(MyRow, 9).Value * 1.15
row = row + 1
Loop
and then add the new sheet,
Sheets.Add After:=ActiveSheet
ActiveSheet.Range("A1").Select
Sheets("sheet1").Range("A1:AF1262").AdvancedFilter...
otherwise you'll end up with 3000 sheets
or
create the sheet and then loop through your data
adding data to your new worksheet as you go
MyRow = 2
Sheets.Add After:=ActiveSheet
Do While Cells(row, 6) <> ""
Cells(MyRow, 7).Value = Cells(MyRow, 9).Value * 0.85
Cells(MyRow, 8).Value = Cells(MyRow, 9).Value * 1.15
'do other stuff here
row = row + 1
Loop
MINCUS1308
03-14-2018, 12:32 PM
It seems like you want to update columns 7 & 8 for all 3000 rows
and create a copy (if it meets criteria on Sheets("DIA (4)").Range("G:H") ) of that data on a new spreadsheet?
It may be simpler to just check Sheets("DIA (4)").Range("G:H") for each row
Something like:
Sub calcModO()
Sheets.Add After:=ActiveSheet
MyRow = 2
Do While Sheet1.Cells(MyRow, 6) <> ""
Sheet1.Cells(MyRow, 7).Value = Sheet1.Cells(MyRow, 9).Value * 0.85
Sheet1.Cells(MyRow, 8).Value = Sheet1.Cells(MyRow, 9).Value * 1.15
If ((Sheet1.Cells(MyRow, 7).Value = Sheets("DIA (4)").Cells(MyRow, 7).Value) _
And (Sheet1.Cells(MyRow, 8).Value = Sheets("DIA (4)").Cells(MyRow, 8).Value)) Then
I = 1
Do Until ActiveSheet.Cells(I, 1) = ""
I = I + 1
Loop
ActiveSheet.Cells(I, 7).Value = Sheet1.Cells(I, 1).Value
ActiveSheet.Cells(I, 8).Value = Sheet1.Cells(I, 2).Value
End If
MyRow = MyRow + 1
Loop
End Sub
yitm03
03-14-2018, 12:36 PM
Thank you for your quick response. The point is I need to have the 3000 sheets to import into another program to do back testing over 12 years with the data. I was doing it manually sheet by sheet and than saving as CSV file to import to the other program. So the solution is not what I was looking for but thanks for your help regardless. I already have the modules to save as CSV and delete the 2999 sheets created.
Add all the new data to the sheet.
Save that sheet as CSV.
That Sheet.Cells.Clear.
Repeat
I counted Column Letters on my fingers, so double check.
Not compiled, Not tested
Sub calcModO()
Dim Sht! As Worksheet
Dim ShtA As Worksheet
Dim DIA As Worksheet
Dim Rw As Long 'Always declare Row and column Counters as Long
Dim LR As Long
LR = Sheets("sheet1").Cells(Rows.Count, "G").End(xlUp).Row
Rw = 2 '"Row" is a Keyword and using it as a variable can "Confuse" VBA.
Set DIA = Sheets("DIA (4)")
Application.ScreenUpdating = False 'Uncomment Line after testing
Sheets.Add
Set ShtA = ActiveSheet
For Rw = 2 to LR
With Sht1
Cells(RW, "G") = Cells(Rw, "J") * 0.85
Cells(Rw, "I") = CellsRw, "J").Value * 1.15
.Range("A1:AF1262").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=DIA.Range(Cells(Rw, "G"), Cells(Rw, "H")), _
CopyToRange:=ShtA.Range("A1"),Unique:=False
End with
CSVModule.SaveAsCSV ShtA 'Edit to suit
ShtA.Cells.Clear
Next
Application.Display Alerts = False
ShtA.Delete
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.