I am making a list of financial cost centres of different departments of a company every time it updates in the sheet "Union" i have to update it in number of sheets so I am trying to develop a vba to do that but failed to get desire results, since I am new to vba programming so any favour will just like to fetch fish into the water.
Here is the source sheet "Union"
It goes on till column45 like this having costcentres detail of individual departments.
Now the sheet I want to update is "REC_INT"
It also goes around 250 rows.
You see cost centres are updated in 1st and 3rd but in 4th cost centre 1002-94q not updated and similary more when we go down, moreover when I run the vba again it will update the updated costcentres again and 1002-610 will appear two times here similarly 102-60001.
Sub CostCentresUpdates()
Dim i As Long
Dim x As Long
Dim j As Long
Dim z As Long
Dim q As Long
Dim a As Long
Shex = 200
For i = 10 To Shex Step 1
For j = 1 To 50 Step 1
If Worksheets("REC_INT").Cells(i, 3).Value = Worksheets("Union").Cells(1, j).Value Then
For z = 2 To 20 Step 1
For x = i + 1 To 20 Step 1
If IsEmpty(Worksheets("Union").Cells(z, j).Value) Then
GoTo y
End If
If Worksheets("Union").Cells(z, j).Value = Worksheets("REC_INT").Cells(x, 4).Value Then
GoTo q
End If
If Worksheets("Union").Cells(z, j).Value = "" Then
GoTo a
End If
Worksheets("REC_INT").Rows(x + 1).Insert shift:=xlShiftDown
Worksheets("REC_INT").Rows(x).EntireRow.Copy _
Destination:=Worksheets("REC_INT").Range("A" & Worksheets("REC_INT").Rows.Count).End(xlUp).Offset(x - 1)
Worksheets("REC_INT").Cells(x + 1, 3).Value = ""
Worksheets("REC_INT").Cells(x + 1, 18).Value = ""
Worksheets("REC_INT").Cells(x + 1, 19).Value = ""
Worksheets("REC_INT").Cells(x + 1, 20).Value = ""
Worksheets("REC_INT").Cells(x + 1, 4).Value = Worksheets("Union").Cells(z, j).Value
Next x
q:
Next z
End If
a:
Next j
y:
Next i
End Sub
Related
I am getting an error in the macro I'm working on for a bootcamp project. The idea is that I have refactored the code to make it more efficient, but I'm getting an Overflow error on one of the lines. I think it's due to it trying to divide 0, but I don't know where I've gone wrong in the loop that it is pulling data that would divide by 0. Any ideas? I'm getting the error on this line
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1
in section 4 - '4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
Sub AllStocksAnalysisRefactored()
Dim startTime As Single
Dim endTime As Single
yearValue = InputBox("What year would you like to run the analysis on?")
startTime = Timer
'Format the output sheet on All Stocks Analysis worksheet
Worksheets("All Stocks Analysis").Activate
Range("A1").Value = "All Stocks (" + yearValue + ")"
'Create a header row
Cells(3, 1).Value = "Ticker"
Cells(3, 2).Value = "Total Daily Volume"
Cells(3, 3).Value = "Return"
'Initialize array of all tickers
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
'1a) Create a ticker Index
Dim tickerIndex As Integer
tickerIndex = 0
'1b) Create three output arrays
Dim tickerVolumes(12) As Long
Dim StartingPrices(12) As Long
Dim EndingPrices(12) As Long
''2a) Create a for loop to initialize the tickerVolumes to zero.
For i = 0 To 11
tickerVolumes(i) = 0
Next i
''2b) Loop over all the rows in the spreadsheet.
For i = 2 To RowCount
'3a) Increase volume for current ticker
If Cells(i, 1).Value = tickerIndex Then
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(i, 8).Value
End If
'3b) Check if the current row is the first row with the selected tickerIndex.
'If Then
If Cells(i, 1) = tickerIndex And Cells(i - 1, 1).Value <> tickerIndex Then
StartingPrices(tickerIndex) = Cells(i, 6).Value
End If
'End If
'3c) check if the current row is the last row with the selected ticker
'If the next row’s ticker doesn’t match, increase the tickerIndex.
'If Then
If Cells(i, 1).Value = tickerIndex And Cells(i + 1, 1) <> tickerIndex Then
EndingPrices(tickerIndex) = Cells(i, 6).Value
'3d Increase the tickerIndex.
tickerIndex = tickerIndex + 1
End If
'End If
Next i
'4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("All Stocks Analysis").Activate
tickerIndex = i
Cells(4 + i, 1).Value = tickers(i)
Cells(4 + i, 2).Value = tickerVolumes(i)
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1 ' **this line is causing the error**
Next i
'Formatting
Worksheets("All Stocks Analysis").Activate
Range("A3:C3").Font.FontStyle = "Bold"
Range("A3:C3").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B4:B15").NumberFormat = "#,##0"
Range("C4:C15").NumberFormat = "0.0%"
Columns("B").AutoFit
dataRowStart = 4
dataRowEnd = 15
For i = dataRowStart To dataRowEnd
If Cells(i, 3) > 0 Then
Cells(i, 3).Interior.Color = vbGreen
Else
Cells(i, 3).Interior.Color = vbRed
End If
Next i
endTime = Timer
MsgBox "This code ran in " & (endTime - startTime) & " seconds for the year " & (yearValue)
End Sub
I have an excel document that initially has 1 tab like this:
When I run the "master" macro, it:
Deletes some columns
Adds a row at the top with numbers
Adds a blank sheet called Output
Takes the raw data tab, pastes it in the "output" tab and transposes it from wide to long (all those macros work perfectly)
Finally it counts chunks of rows in the output tab and inserts two rows with summary stats, like so:
So far, this is mostly the behavior I'd like. The 65 is in the correct spot. Id like it to show "91" right underneath that (the sum of the entire column so far), but at least the 65 is correct.
The more pressing problem is some of the following summary rows. For instance the very next summary rows have 91 where it should be, but an incorrect blank above it:
And then the following summary rows should be 100,100 and instead it says 0,91:
and the summary row after that should be 100,100 but is 0,191!
I'm less familiar pasting excel VBA onto stack (usually on the R side of things), but I think the problem is somewhere in this macro:
'ADD THE EXCEL FORMATTING********************************************************************
Sub format()
Dim lastRow As Long, rawRow As Long, rawCol As Long, writeRow As Long
'count total number of rows
lastRow = Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Row
'set starting places, first row with info is 3 while trouble shooting but 2 normally
x = 1
Row = 2
'Set sum counter to add up all no cost center values
total_RE_sum = 0 'total research effort actual
total_REp_sum = 0 'total research effort previous
total_REb_sum = 0 'total research effort budgeted
total_E_sum = 0 'total effort actual
total_Ep_sum = 0 'total effort previous
total_Eb_sum = 0 'total effort budgeted
'Start loop*****************************************************************************
'where it finds ROW = 20 inserts 2 rows below
For x = 1 To lastRow
'For x = 1 To 66
If Cells(Row, 11) = 20 Then
Rows(Row + 1).EntireRow.Insert
Rows(Row + 1).EntireRow.Insert
' Cells(Row + 1, 8).NumberFormat = "0%"
' Cells(Row + 1, 9).NumberFormat = "0%"
' Cells(Row + 1, 10).NumberFormat = "0%"
' Cells(Row + 2, 8).NumberFormat = "0%"
' Cells(Row + 2, 9).NumberFormat = "0%"
' Cells(Row + 2, 10).NumberFormat = "0%"
Cells(Row + 1, 7) = "Total Research Effort"
Cells(Row + 2, 7) = "Total Effort"
' insert reseach effort previous and actual
Cells(Row + 1, 8) = total_REb_sum
Cells(Row + 1, 9) = total_REp_sum
Cells(Row + 1, 10) = total_RE_sum
' insert total effort previous and actual
Cells(Row + 2, 8) = total_Eb_sum
Cells(Row + 2, 9) = total_Ep_sum
Cells(Row + 2, 10) = total_Ep_sum
'2 rows are added in this step because the new row jsut added in this step adds to the increment
Row = Row + 2
'reset sum to 0 because I moved to a new person
total_RE_sum = 0 'total research effort actual
total_REp_sum = 0 'total research effort previous
total_REb_sum = 0 'total research effort budgeted
total_E_sum = 0 'total effort actual
total_Ep_sum = 0 'total effort previous
total_Eb_sum = 0 'total effort budgeted
ElseIf Row >= 7 And Row <= 20 Then
total_RE_sum = total_RE_sum + Cells(Row, 10).Value 'total research effort actual
total_REp_sum = total_REp_sum + Cells(Row, 9).Value 'total research effort previous
total_REb_sum = total_REb_sum + Cells(Row, 8).Value 'total research effort budgeted
total_E_sum = total_E_sum + Cells(Row, 10).Value 'total effort actual
total_Ep_sum = total_Ep_sum + Cells(Row, 9).Value 'total effort previous
total_Eb_sum = total_Eb_sum + Cells(Row, 8).Value 'total effort budgeted
Row = Row + 1
Else
total_E_sum = total_E_sum + Cells(Row, 10).Value 'total effort actual
total_Ep_sum = total_Ep_sum + Cells(Row, 9).Value 'total effort previous
total_Eb_sum = total_Eb_sum + Cells(Row, 8).Value 'total effort budgeted
Row = Row + 1
End If
Next
End Sub
I'm not sure at all where the macro went wrong, I wasn't the original author. Thank you!
Notes:
I am only appending for the solution looked as stated,on a personal note I think the whole logic needs to be revised. The problem stated could be better worded for others to understand the logic without the need of downloading the file. In relation to selections used in the pre process look at this topic to avoid selection. Bottom line: You are right, the module format is the one needed to be fixed, I changed the whole logic for it
Demo:
Code:
Sub format_alternative()
Const NumRowsToAppend As Long = 20
Dim NumTotalRows As Long
Dim TotalCyclesToPerfom As Long
Dim CounterCyclesToPerform As Long
Dim NumRowsAppended As Long
Dim IsFixLast As Boolean
Dim NumRowResearchEffort As Long
Dim NumRowTotalEffort As Long
With Sheets("Output")
NumTotalRows = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
TotalCyclesToPerfom = NumTotalRows / NumRowsToAppend
'It means for last cycle there are not enough rows to do it as for others, so we need to append for that
IsFixLast = IIf(NumTotalRows Mod NumRowsToAppend <> 0, True, False)
NumRowsAppended = 1
For CounterCyclesToPerform = 1 To TotalCyclesToPerfom
If CounterCyclesToPerform = TotalCyclesToPerfom And IsFixLast = True Then ' 1. If CounterCyclesToPerform = TotalCyclesToPerfom And IsFixLast = True
'I'm going to leave this scenario for you to try to understand the logic and when it happens you fix it accordingly
Else ' 1. If CounterCyclesToPerform = TotalCyclesToPerfom And IsFixLast = True
NumRowResearchEffort = (NumRowsToAppend * CounterCyclesToPerform) + 1 + NumRowsAppended
NumRowTotalEffort = (NumRowsToAppend * CounterCyclesToPerform) + 2 + NumRowsAppended
End If ' 1. If CounterCyclesToPerform = TotalCyclesToPerfom And IsFixLast = True
.Rows(NumRowResearchEffort & ":" & NumRowTotalEffort).Insert
.Cells(NumRowResearchEffort, 7) = "Total Research Effort"
.Cells(NumRowTotalEffort, 7) = "Total Effort"
' insert reseach effort previous and actual. I changed for a formula so it's easier for the user to see what's going on calculations
.Cells(NumRowResearchEffort, 8).Formula = "=SUM(H" & NumRowResearchEffort - 11 & ":H" & NumRowResearchEffort - 1 & ")"
.Cells(NumRowResearchEffort, 9).Formula = "=SUM(I" & NumRowResearchEffort - 11 & ":I" & NumRowResearchEffort - 1 & ")"
.Cells(NumRowResearchEffort, 10).Formula = "=SUM(J" & NumRowResearchEffort - 11 & ":J" & NumRowResearchEffort - 1 & ")"
' insert total effort previous and actual. I changed for a formula so it's easier for the user to see what's going on calculations
.Cells(NumRowTotalEffort, 8).Formula = "=SUM(H" & NumRowResearchEffort - NumRowsToAppend & ":H" & NumRowResearchEffort - 1 & ")"
.Cells(NumRowTotalEffort, 9).Formula = "=SUM(I" & NumRowResearchEffort - NumRowsToAppend & ":I" & NumRowResearchEffort - 1 & ")"
.Cells(NumRowTotalEffort, 10).Formula = "=SUM(J" & NumRowResearchEffort - NumRowsToAppend & ":J" & NumRowResearchEffort - 1 & ")"
NumRowsAppended = NumRowsAppended + 2
Next CounterCyclesToPerform
End With
End Sub
I'm trying to create a macro that outputs all possible permutations starting with a column of some numbers where each consecutive number can't be greater than the number above it.
So, would I would like to do is to provide excel with a column of 15 values in Sheet1 ranging from 1 to 9. The values should be in descending order so that a number on a row below can never exceed the one above.
What I am trying to do is to output new permutations of this list, one new sheet per new list.
The upper limit of the values in the list would be specified so the number of permutations would be everything between the starting list and the upper limit value.
There is a condition that I can not break and that is that the value of a row below another row, can't have a greater value than the one above. There's an image that explains a bit.
So far my code is not even half way there and I feel completely lost.
I'm not even sure how to go about thinking about this problem let alone coding it.
Any input would be greatly appreciated.
Sub
doSomeStuff()
Dim maxNotch, startNotch, Counter As Integer
Dim shit As Range
maxNotch = 3
startNotch = ThisWorkbook.Sheets("Sheet1").Cells(2, 2)
Counter = startNotch
sheetnumber = 2
For j = st
artNotch To maxNotch
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Sheet" & sheetnumber
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(2, 2).Value = Counter
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 1).Value = 2 + i
If ThisWorkbook.Sheets("Sheet" & sheetnumber).Cells(i + 1, 2).Value <> Counter Then
k = Counter - ThisWorkbook.Sheets("Sheet" & sheetnumber - 1).Cells(i + 1, 2).Value
Debug.Print k
End If
Next i
sheetnumber = sheetnumber + 1
Counter = Counter + 1
Next j
Application.DisplayAlerts = True
End Sub
Function pop()
(ByVal j As Integer, k As Integer)
For i = 1 To 3
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 1).Value = 2 + i
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(2, 2).Value = Counter
If ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value <> Cou
nter Then
ThisWorkbook.Sheets("Sheet" & j + 1).Cells(i + 1, 2).Value = ThisWorkbook.Sheets("Sheet" & j).Cells(i + 1, 2).Value
End If
Next i
End Function
Example from my comment, to account for the ordering:
dim pc as long, ws as worksheet
for each ws in worksheets
with ws
If ws.name <> "sourcedatasheet" then
.cells(2,2).resize(pc).value = "" 'export your list; pc = permutation count
.Range(.Cells(1,2),.Cells(pc+1,2)).Sort key1:=.Cells(1,2), order1:=xlDescending, Header:=xlYes 'used a header because row 1 is blank
end if
end with
next
Edit1:
Adding an if-statement to account for some specific sheet to not be included
I have 16k rows of data. There are two columns with time. What i need is to find rows where time doesn't match and move everyhing below in last 3 columns down on one, so at the end I'll have all rows with time match and those that dont would have last 3 columns blank in that row.
here what I have so far, but I'm new to VBA and this doesnt work(
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
Else: ThisWorkbook.Sheets("L5").Range("Gx:Iy").Select
Selection.Offset(1, 0).Select
y = y + 1
End If
x = x + 1
Loop
The following code should do it. Check whether the right ranges and cells are used; I tried to figure it out from your code:
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
' nothing
Else
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x)) & ":I" & Trim(Str(y))).Cut
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x + 1))).Select
ThisWorkbook.Sheets("L5").Paste
y = y + 1
End If
x = x + 1
Loop
End Sub
i'm a complete noob in vba so i'm searching all over the net to combine the code but right now it seems i hit the great wall and can't get it right. what i wanna do are:
to sum every row above and add extra row above (somehow i get this
right)
in extra row (i said above) i want to count every cells above that have value more than zero (in excel i use simple count if formula but i cant do it in vba)
to loop the step above in another sheet in this workbook except sheet 1 (the quantity of sheets can vary depend on the input, so i believe this can be done by loop but i dont know how)
to copy the output of the step above into sheet 1
this is my code so far and since i cant do loop i did it manualy for sheet2 and sheet3. i get stuck in step 2
here is the code that've been modified taken from #NEOman' code
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowscount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowscount)
'Counting the number of cells which value greater than zero
If Cells(j, 9) > 0 Then
temp = temp + 1
End If
Next j
'Counting the number of rows for automation
rowscount1 = Cells(Rows.Count, 1).End(xlUp).Row
temp1 = 0
For i = 2 To (rowscount1)
'Counting the number of cells which value greater than zero
If Cells(i, 10) > 0 Then
temp1 = temp1 + 1
End If
Next i
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowscount + 1, 9).Value = Application.Sum(Range(Cells(1, 9), Cells(rowscount, 9)))
Cells(rowscount + 2, 9) = temp
'copy ke sheet 1
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowscount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
Cells(rowscount1 + 1, 10).Value = Application.Sum(Range(Cells(1, 10), Cells(rowscount1, 10)))
Cells(rowscount1 + 2, 10) = temp1
'copy ke sheet 1
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 1).Value = Cells(rowscount1 + 2, 1).Value
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 2).Value = temp1
K = K + 1
End If
Next ws
End Sub
i know my code is a mess and i wrote comment in every step i did so that i know what the codes are doing. i use different code for column I and J but neither works :(. any help will be appreciated, thanks in advance for your attention.
===========================================================================================
the code must be run in every sheet (except sheet1) manualy, so im still trying to make the code run from sheet1 but work on any other sheet in same workbook. any help will be appreciated, thanks in advance for your attention.
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowsCount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowsCount)
'Counting the number of cells which value greater than zero
If Cells(j - 1, 1) > 0 Then
temp = temp + 1
End If
Next j
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowsCount + 1, 1).Value = Application.Sum(Range(Cells(1, 1), Cells(rowsCount, 1)))
Cells(rowsCount + 1, 2) = temp
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowsCount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
End If
Next ws
End Sub