Related
I'm writing a VBA code for a workbook with 7 pages. Each page has stock data in the same layout. Each stock is identified with a ticker, and has data for opening, closing, high, low, and volume for each day of the year.
I want a code that will create a new column for the ticker, and beside that columns for Yearly Change, Percent Change, and Total Volume.
I want to be able to run the macro once and have it loop through every page for the workbook. It will label the ticker and calculate the Total Stock Volume on each page, but it only calculates the Yearly Change and Percent Change for the last page.
This is what should happen on each page
This is what all but the last page look like
As you can see from the images, it's doing part of the code on each page, but only the last page gets the entire code applied thereto.
Could anyone tell me what's going on or give me a hint? The macro is definitely running through each page since columns I and L are getting done, but columns J and K are only done on the last page.
Here is the code I'm using:
Sub Stocks()
'This creates a "worksheet loop" that will automatically cycle through each page of the workbook and apply the macro thereto.
Dim sheets As Worksheet
For Each sheets In ThisWorkbook.Worksheets
sheets.Activate
'The proceeding lines create the column headings, as well as the headings horizontal headings used to show the greatest and least perchange change as well as the greatest total volume.
Range("I1").Value = "Ticker"
Range("J1").Value = "Yearly Change"
Range("K1").Value = "Percent Change"
Range("L1").Value = "Total Stock Volume"
Range("P1").Value = "Ticker"
Range("Q1").Value = "Value"
Range("O2").Value = "Greatest % Increase"
Range("O3").Value = "Greatest % Decrease"
Range("O4").Value = "Greatest Total Volume"
Range("O5").Value = "Least Total Volume"
'This creates a variable which will identify and label the stock ticker.
Dim stock_ticker As String
'This creates a variable which will hold the total stock volume.
Dim stock_volume As Double
stock_volume = 0
'This variable is used to input the ticker value in the correct cell in column I. The ticker changes at a faster rate in column I than in column A. This variable is therefore used to adjust the rate tickers are copied over from column A to column I.
Dim j As Integer
j = 2
'This loop checks to see if the value in cell 'Ax" is equal to "Ay", where x and y are integers, and y=x+1. If they are equal, Excel will recognize the tickers as being the same, and add the stock volume in the xth row to an accumlative total stock volume. If Ax does not equal Ay, Excel will recognize that the ticker just changed. When this happens, Excel will will add the last stock volume for the current ticker to the accumlative total stock volume; then it will identify what the current ticker is and insert this into column I, insert the total stock volume for that ticker into column L, then reset the total stock volume back to 0, then repeat the process.
For i = 2 To 43398
If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
stock_volume = stock_volume + Cells(i, 7).Value
ElseIf Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
stock_volume = stock_volume + Cells(i, 7).Value
Cells(j, 9).Value = Cells(i, 1).Value
Cells(j, 12).Value = stock_volume
j = j + 1
stock_volume = 0
End If
Next i
Dim stock_year_start As Double
Dim stock_year_end As Double
Dim stock_year_change As Double
Dim stock_percent_change
Dim k As Integer
k = 2
For i = 2 To 43398
If Right(Cells(i, 2), 4) = "0101" Then
stock_year_start = Cells(i, 3)
ElseIf Right(Cells(i, 2), 4) = "1231" Then
stock_year_end = Cells(i, 6)
stock_year_change = stock_year_end - stock_year_start
stock_percent_change = stock_year_change / stock_year_start
Cells(k, 10).Value = stock_year_change
If Cells(k, 10).Value > 0 Then
Cells(k, 10).Interior.ColorIndex = 4
ElseIf Cells(k, 10).Value < 0 Then
Cells(k, 10).Interior.ColorIndex = 3
End If
Cells(k, 11).Value = stock_percent_change
k = k + 1
End If
Next i
Range("K1").EntireColumn.NumberFormat = "0.00%"
'The proceeding lines automatically resize the cells created throughout the program to fit the content therein.
Dim sheet_name As String
sheet_name = ActiveSheet.Name
Worksheets(sheet_name).Columns("I:L").AutoFit
Worksheets(sheet_name).Columns("O:Q").AutoFit
'This cycles to the next page in the workbook and repeats all the code hitherto.
Next sheets
End Sub
I would avoid dimming variables with object names, so consider changing the Sheets in Dim sheets as Worksheet to ws.
To loop through sheets and apply the same logic you need to do something like this:
Dim ws as Worksheet
For Each ws in Worksheets
'Your code goes here with all objects referring to current ws like so:
ws.Range(....
ws.Cells(....
Next ws
Do not activate the sheet. Instead, qualify every object (Range, Cells, etc) with the variable ws. I would use a find & replace and swap Range with ws.Range and then swap Cells with ws.Cells. It would look something like this in your code.
Sub Stocks()
Dim stock_ticker As String, stock_volume As Double, j As Integer
Dim ws As Worksheet
For Each ws In Worksheets
ws.Range("I1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
ws.Range("P1").Value = "Ticker"
ws.Range("Q1").Value = "Value"
ws.Range("O2").Value = "Greatest % Increase"
ws.Range("O3").Value = "Greatest % Decrease"
ws.Range("O4").Value = "Greatest Total Volume"
ws.Range("O5").Value = "Least Total Volume"
stock_volume = 0
Dim j As Integer
j = 2
For i = 2 To 43398
If ws.Cells(i, 1).Value = ws.Cells(i + 1, 1).Value Then
stock_volume = stock_volume + ws.Cells(i, 7).Value
ElseIf ws.Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
stock_volume = stock_volume + ws.Cells(i, 7).Value
ws.Cells(j, 9).Value = ws.Cells(i, 1).Value
ws.Cells(j, 12).Value = stock_volume
j = j + 1
stock_volume = 0
End If
Next i
I found the problem. Most stocks end on 12/30, and I was only checking for 12/31. I have rewritten the second loop as:
For i = 2 To 43398
If Right(workbook_sheet.Cells(i, 2), 4) = "0101" Then
stock_year_start = workbook_sheet.Cells(i, 3)
ElseIf Right(workbook_sheet.Cells(i, 2), 4) = "1231" Then
stock_year_end = workbook_sheet.Cells(i, 6)
stock_year_change = stock_year_end - stock_year_start
stock_percent_change = stock_year_change / stock_year_start
workbook_sheet.Cells(k, 10).Value = stock_year_change
ElseIf Right(workbook_sheet.Cells(i, 2), 4) = "1230" Then
stock_year_end = workbook_sheet.Cells(i, 6)
stock_year_change = stock_year_end - stock_year_start
stock_percent_change = stock_year_change / stock_year_start
workbook_sheet.Cells(k, 10).Value = stock_year_change
If workbook_sheet.Cells(k, 10).Value > 0 Then
workbook_sheet.Cells(k, 10).Interior.ColorIndex = 4
ElseIf workbook_sheet.Cells(k, 10).Value < 0 Then
workbook_sheet.Cells(k, 10).Interior.ColorIndex = 3
End If
workbook_sheet.Cells(k, 11).Value = stock_percent_change
k = k + 1
End If
Next i
I'm thinking of a more elegant way of finding the year-end stock value. The 43398 is also a temporary value, as each page has a different number of stocks to check for and I'm still looking for a while to find the number of rows in each field.
I'll leave this here in case anyone wants to comment.
I would like to ask how to SUM the values quickly, when they are separated 30 rows from each other?
I would like to sum 9 values and input the result in different column as per the code below:
Sub sum()
Range("EG12").Formula = "=Sum(C12,C282, C552, C822,C1092,C1362,C1632,C1902,C2172,C2442)"
Range("EG42").Formula = "=Sum(C42,C312,C582, C852,C1122,C1392,C1662,C1932,C2202,C2472)"
Range("EG72").Formula = "=Sum(C72,C342,C612, C882,C1152,C1422,C1692,C1962,C2232,C2502)"
Range("EG102").Formula = "=Sum(C102,C372,C642,C912,C1182,C1452,C1722,C1992,C2262,C2532)"
End Sub
Where as you may have notice every destination cell is located exactly 30 rows between each other (inner rows are empty or contains different values) likewise copied cells, that are located exactly 270 rows between each other (see the image attached).
I was trying to do formula like this:
Sub sum2()
Dim lastrow As Long, i As Integer, total As Double, finalsum As Double
lastrow = Range("C2442").End(xlUp).Row
For i = 30 To lastrow
total = total + WorksheetFunction.sum(Range("C12" & i & "EG12" & i))
Next
finalsum = total
End Sub
...but I've got "Method 2Range of object2_Global failed.
Does somebody have some idea about this?
Thanks & regards,
I didn t make it that pretty with the 170 sum but you should understand the point like this:
Sub test2()
Dim lastrow As Long, i As Long, finalsum As Long
lastrow = Range("C2442").End(xlUp).Row
finalsum = 0
For i = 12 To lastrow Step 30
Range("E" & i).Value = WorksheetFunction.Sum(Cells(i, 3).Value, Cells(i + 170, 3).Value, Cells(i + 2 * 170, 3).Value, Cells(i + 3 * 170, 3).Value, Cells(i + 4 * 170, 3).Value, Cells(i + 5 * 170, 3).Value, Cells(i + 6 * 170, 3).Value, Cells(i + 7 * 170, 3).Value, Cells(i + 8 * 170, 3).Value, Cells(i + 9 * 170, 3).Value)
finalsum = finalsum + Range("E" & i).Value
Next i
End Sub
Try it with loops and unions.
Option Explicit
Sub sum30by270()
Dim i As Long, j As Long, lr as long
Dim r1 As Range, r2 As Range
With Worksheets("sheet2")
lr = .cells(.rows.count, "C").end(xlup).row
Set r1 = .Cells(12, "C")
For i = 282 To lr Step 270
Set r1 = Union(r1, .Cells(i, "C"))
Next i
'Debug.Print r1.Address(0, 0)
Set r2 = .Cells(12, "EG")
For j = 42 To 102 Step 30
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
'Debug.Print r2.Address(0, 0)
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Few remarks:
lastrow = Range("C2442").End(xlUp).Row
is not the right usage, you might want to change it to:
'going from specified cell down until empty cell is met
lastrow = Range("C2442").End(xlDown).Row
or
'going from last cell in C column up, until first non-empty cell is met
lastrow = Range(Rows.Count, 3).End(xlUp).Row
Second issue, if you want to loop every 30 rows, you should do it like this (also remember about proper indentation of your code!):
For i = 12 To lastrow Step 30
total = total + WorksheetFunction.Sum(Range(Cells(i, 1), Cells(i, 5)))
Next
finalsum = total
"C12" & i & "EG12" & i - & operator is a string concatenation, not addition, this is why you might get unexpected result.
Well, thank you all guys for our contribution. I would like to add final working formula for this issue:
Sub sum_1to10()
Dim i As Long, j As Long, lr As Long
Dim r1 As Range, r2 As Range
With Worksheets("13")
lr = .Cells(.rows.Count, "C").End(xlUp).Row
Set r1 = .Cells(12, "C") 'First cell with data in my worksheet - [![enter image description here][1]][1] C12
For i = 12 To 2442 Step 270 ' From 1st cell with data to 10th cell in this order C2442
'When put "lr" instead 2442 the values will be calculated as per all worksheet data included (in my case it was down to 8377
Set r1 = Union(r1, .Cells(i, "C"))
Next i
Set r2 = .Cells(12, "Eh")
For j = 12 To 1086 Step 30 'First subsequent cell with data with 30 rows step e.g C42, C72, etc
' Value 1086 correspond to the last row in label with sum
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Hopefully I have understood it well.
I decided to modify this formula in order to divide my calculation on 3 separate parts. I am making these bulk calculation for every month, and I have divided it for 3 decades.
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
Is there someone can help me? I have here code that can duplicate entire row to have 2 rows. After duplicating the first entire row , I want to load string from range "G" into array so that I can get certain string that Am planning to insert in "Thickness" and "width" column for me to use to calculate the "Weight" of the "Profile Type". If you will see I have an array in the code .But that array work differently for me and I had a hard time fulfilling the requirements I need. The array in my code split the String using "X" as delimiter . Once the string was split it will add another cells for each split string. what I want is to do the split not in the column but in the array only so that I can maintain the data in G . I will use the string assigned in the array to get "Thickness and Width" of the profile which is "15 as Thickness and 150 as width". If there's any way to do same thing using other code it will be more helpful to simplify the code.
Reminder that Profiletype string vary its length . Sometimes profile width are 4 digits (LB1000X4500X12/15)
Below are the snapshot of my worksheet for you to identify what the result will be.
Private Sub CommandButton2_Click()
Dim lastrow As Long
Dim i As Integer
Dim icount As Integer
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
'array
'Columns("G:G").NumberFormat = "#"
Dim c As Long, r As Range, v As Variant, d As Variant
For i = 2 To Range("G" & Rows.Count).End(xlUp).Row '2 to 16 cell
'v = Split (range("G" & i), "X")
v = Split((Cells(x, "G") & i), "x")
c = c + UBound(v) + 1
'Next i
For i = 2 To c
If Range("G" & i) <> "" Then
Set r = Range("G" & i)
Dim arr As Variant
arr = Split(r, "X")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert Shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, -2) = r.Offset(0, -2)
Next j
End If
Next i
End If
Next x
End Sub
Does this do what you want? Run in copy of workbook to be safe.
Option explicit
Private Sub CommandButton2_Click()
'Bit redundant, would be better if you fully qualify workbook and worksheet with actual names.'
Dim TargetWorksheet as worksheet
Set TargetWorksheet = Activesheet
With application
.screenupdating = false
.calculation = xlcalculationmanual
End with
With TargetWorksheet
.range("G:G").numberformat = "#"
Dim RowIndex As Long
For RowIndex = .usedrange.rows.countlarge to 1 step -1
If .Cells(RowIndex, "F").value2 = "LB" Then
.Cells(RowIndex, "F").value2 = "ComP"
.Cells(RowIndex + 1, "F").EntireRow.Insert
.Cells(RowIndex, "F").EntireRow.Copy .Cells(RowIndex + 1, "F").EntireRow
Dim SplitProfileType() as string
SplitProfileType = split(mid(.cells(RowIndex+1,"G").value2,3), "X") ' assumes first two characters will always be LB, that it is safe to ignore them and start from third character.'
' Write thickness'
.cells(RowIndex+1, "H").value2 = cdbl(mid(SplitProfileType(ubound(SplitProfileType)),instrrev(SplitProfileType(ubound(SplitProfileType)),"/",-1,vbbinarycompare)+1)
' Write width'
.cells(RowIndex+1, "i").value2 = cdbl(SplitProfileType(1))
' Calculate weight'
.cells(RowIndex+1,"K").value2 = .cells(RowIndex+1,"H").value2 * .cells(RowIndex+1,"I").value2 * .cells(RowIndex+1,"J").value2
End if
' I think because you are inserting a row below (rather than above/before), your RowIndex remains unaffected and no adjustment is needed to code. I could be wrong. I would need to test it to be sure.'
Next rowindex
End with
With application
.screenupdating = true
.calculation = xlcalculationautomatic
End with
End sub
Untested as written on mobile.
It works without duplication.
Sub test2()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim r As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
For i = 1 To n
If vDB(i, 6) = "LB" Then
r = 2
Else
r = 1
End If
k = k + r
ReDim Preserve vR(1 To 11, 1 To k)
s = vDB(i, 7)
For j = 1 To 11
If r = 1 Then
vR(j, k) = vDB(i, j)
Else
vR(j, k - 1) = vDB(i, j)
vR(j, k) = vDB(i, j)
End If
Next j
If r = 2 Then
vR(6, k - 1) = "comp"
vR(6, k) = "comp"
vR(8, k) = Split(s, "/")(1)
vR(9, k) = Split(s, "X")(1)
vR(9, k - 1) = vR(9, k - 1) - vR(8, k)
vR(11, k - 1) = (vR(8, k - 1) * vR(9, k - 1) * vR(10, k - 1) * 7.85) / 10 ^ 6 '<~~ k2 weight
vR(11, k) = (vR(8, k) * vR(9, k) * vR(10, k) * 7.85) / 10 ^ 6 '<~~ k3 weight
End If
Next i
Range("f1") = "Type"
Range("a2").Resize(k, 11) = WorksheetFunction.Transpose(vR)
End Sub
It is faster to use an array than to enter it one-to-one in a cell.
Sub test()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
ReDim vR(1 To n * 2, 1 To 11)
For i = 1 To n
k = k + 2
s = vDB(i, 7)
For j = 1 To 11
vR(k - 1, j) = vDB(i, j)
vR(k, j) = vDB(i, j)
Next j
vR(k - 1, 6) = "comp"
vR(k, 6) = "comp"
vR(k, 8) = Split(s, "/")(1)
vR(k, 9) = Split(s, "X")(1)
vR(k, 11) = Empty '<~~ This is calculated Weight value place
Next i
Range("f1") = "Type"
Range("a2").Resize(n * 2, 11) = vR
End Sub
I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.
Below is a table of how the data looks.
Below is how I would like the data to look
Try this simple code,
Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i - 1, 1) Then
j = j + 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
Else
k = k + 3
j = 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
End If
Next i
End Sub
Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.
I had to do something similar. You can try also this code:
Sub Move_Data()
Application.ScreenUpdating = False
Dim r As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim ColA As Integer
Dim vLastRow As Integer
Dim vEnd As Integer
r = 1
StartRow = 1
EndRow = 1
ColA = 4
vEnd = 1
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
vEnd = r
Do Until r > vLastRow
DoEvents
StartRow = r
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
EndRow = r - 1
Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select
Selection.Copy
Cells(1, ColA).Select
ActiveSheet.Paste
ColA = ColA + 3
Loop
r = vEnd + 1
Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents
Cells(1, 1).Select
Application.ScreenUpdating = True
MsgBox "Done"
End Sub