I was provided with some code that a guy who is not longer available did. say you have a table with five columns. the first four columns get filled with a query that works fine, then there is this piece of code that completes the fifth column. When I run it it gets me "Subscript out of range (Error 9)" when it goes for the fifth row and below. The 1,2,3 and 4 work ok. Any help would be great! The error is highlighted on the line above the fisrt "for"
Function HorasSemana() As Double
Dim sumaHoras As Double
Dim lRow As Integer
Dim semanas(1 To 4) As Integer
lRow = DatosOmnia.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lRow
semanas(i - 1) = WorksheetFunction.WeekNum(DatosOmnia.Cells(i, "C"), vbMonday)
'MsgBox WorksheetFunction.WeekNum(DatosOmnia.Cells(i, "C"), vbMonday)
Next i
'lRow toma el valor con respecto a la hoja "Horas Semanales"
lRow = Worksheets("Horas Semanales").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To sizeOf(semanas) '(UBound(semanas, 1) - LBound(semanas, 1) + 1)
sumaHoras = 0
For j = 2 To lRow
If WorksheetFunction.WeekNum(Worksheets("Horas Semanales").Cells(j, "B"), vbMonday) = semanas(i) Then
sumaHoras = sumaHoras + Worksheets("Horas Semanales").Cells(j, "C").Value
DatosOmnia.Cells(i + 1, "F") = sumaHoras
End If
Next j
Next i
HorasSemana = sumaHoras
End Function
You can resize your array according to lRow:
Dim lRow As Long
Dim semanas() As Long
lRow = DatosOmnia.Cells(Rows.Count, 1).End(xlUp).Row
ReDim semanas(1 to lRow-1)
Typically Long is preferable to Integer - it doesn't "cost" more, and it's safer if your data grows larger
Related
I have sheet which contains lots of column data, first column is date one in second column there are quantities and in the third one there are codes of item :
the data looks like this :
date qty code qty code
01.01.2022 0 4355 2 4356
02.01.2022 0 4355 2 4356
03.01.2022 0 4355 2 4356
....................................
and I want to have like this :
date qty code
01.01.2022 0 4355
02.01.2022 0 4355
03.01.2022 0 4355
01.01.2022 2 4356
02.01.2022 2 4356
03.01.2022 2 4356
I wrote the code in visual basic for macro which cuts fourth and fifth columns pasts at the end of second and third columns and then deletes empty columns and continuous until there are no empty columns my code works but it takes hours to execute on 1000+ columns and I want to know if there is any possible way to optimize it.
code:
Sub CutAndPasteColumnsUntilEmpty()
Dim lastRow As Long
Dim i As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
Do Until IsEmpty(Range("D2")) And IsEmpty(Range("E2"))
Range("D2:D" & lastRow).Cut Destination:=Range("B" & lastRow + 1)
Range("E2:E" & lastRow).Cut Destination:=Range("C" & lastRow + 1)
lastRow = ActiveSheet.UsedRange.Rows.Count
Columns("D:E").Delete
Loop
End Sub
This routine doesn't copy/paste any data.
It reads your table into an array, then creates a new array from that input array in the format you want. It then creates a new tab and writes the output to that tab. It should take seconds, not hours.
This will output by reading each row at a time.
Sub ReorganiseTable()
'Declarations
Dim LastRow As Long
Dim LastColumn As Long
Dim NoOfRows As Long
Dim NoOfColumnSets As Long
Dim o As Long, r As Long, c As Long
With ActiveSheet
'Find Last Row of table
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NoOfRows = LastRow - 1
'Find Last Column of table
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
NoOfColumnSets = (LastColumn - 1) / 2
'Copy table to array
Dim ArrInput
ArrInput = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(LastRow, LastColumn)).Value
'Create output array for filling
ReDim ArrOutput(1 To NoOfColumnSets * NoOfRows + 1, 1 To 3)
'Copy headers across
ArrOutput(1, 1) = ArrInput(1, 1)
ArrOutput(1, 2) = ArrInput(1, 2)
ArrOutput(1, 3) = ArrInput(1, 3)
'Copy data across order by rows,columns
o = 2
For r = 2 To LastRow
For c = 2 To LastColumn Step 2
ArrOutput(o, 1) = ArrInput(r, 1)
ArrOutput(o, 2) = ArrInput(r, c)
ArrOutput(o, 3) = ArrInput(r, c + 1)
o = o + 1
Next
Next
End With
'Create a new tab
Worksheets.Add
'Write output array to tab
ActiveSheet.Cells(1, 1).Resize(UBound(ArrOutput), 3).Value = ArrOutput
End Sub
If you'd prefer it ordered by reading each column set at a time, invert the two For statements:
'Copy data across order by rows,columns
o = 2
For c = 2 To LastColumn Step 2
For r = 2 To LastRow
ArrOutput(o, 1) = ArrInput(r, 1)
ArrOutput(o, 2) = ArrInput(r, c)
ArrOutput(o, 3) = ArrInput(r, c + 1)
o = o + 1
Next
Next
This is one of those occasions when the OP may be reaching for VBA too soon. The task can also be achieved via spreadsheet functions (if the Excel version is recent enough):
The formula in cell G2 is:
=LET(n,COUNTA(A:A)-1,arr,OFFSET(A2:E2,0,0,n),r,SEQUENCE(n*2),c,SEQUENCE(,3),IF(r>n,INDEX(arr,r-n,IF(c>1,c+2,c)),INDEX(arr,r,c)))
The LET function allows you to do intermediate calculations and store the result in a variable.
n = number of rows in the input data
arr = input array (resized from first row in data, for n rows)
r = a vector of rows (1 .. 2n) in the output table
c = a vector of columns (1 .. 3) in the output table
The final parameter is the calculation, which takes columns (1,2,3) from the input for the first n rows of the output table, and thereafter takes columns (1,4,5) for rows n+1 to 2n.
This has the benefits that the sheet can remain a .xlsx file (and hence avoid security warnings) and the output columns will update automatically (with calc set to auto) as new data is added to the input. It will also be faster than VBA.
Stack Columns
It looks like it's written for any number of columns (Cols, Current) but it isn't (too lazy).
It only works for stacking column pairs to the first column.
The total number of columns is supposed to be odd (first + even).
It also includes the headers.
=LET(Data,A1:K7,Cols,2,
Current,TAKE(Data,,1+Cols),First,DROP(TAKE(Data,,1),1),Other,DROP(Data,1,1+Cols),
rCount,ROWS(First),cCount,COLUMNS(Other),cCountHalf,rCount*cCount/Cols,
SeqFirst,MOD(SEQUENCE(cCountHalf)-1,rCount)+1,
SeqOther,Cols*ROUNDUP(SEQUENCE(cCountHalf,,,Cols)/(Cols*rCount),0)-1,
VSTACK(Current,HSTACK(INDEX(First,SeqFirst),
INDEX(Other,SeqFirst,SeqOther),INDEX(Other,SeqFirst,SeqOther+1))))
Regarding to CLRs solution i would like to show my additional variant. With this one you can vary the columnsets as you wish.
Sub ReorganizeTable()
Dim arrA As Variant
Dim arrB As Variant
Dim c As Long
Dim r As Long
Dim isFirstRun As Boolean
Dim ColumnSet As Long
Dim RowSet As Long
Dim maxCols As Long
Dim maxRows As Long
Dim maxSets As Long
Dim ToggleCol As Integer
ColumnSet = 3 'set your columns here
With Cells(1, 1).CurrentRegion 'get dimension and array
maxRows = .Rows.Count - 1 '-1 = remove headers if available
maxCols = .Columns.Count
arrA = .Offset(1, 0).Resize(maxRows, maxCols)
End With
maxSets = maxCols / ColumnSet
ReDim arrB(1 To maxRows * maxSets, 1 To ColumnSet)
isFirstRun = True
For c = 0 To maxCols - 1 'must not start with 1, see ToggleCol below
ToggleCol = c Mod ColumnSet + 1 'switches between 1 and 2 but has to start with 1
If Not isFirstRun Then
If ToggleCol = 1 Then
RowSet = RowSet + maxRows
End If
End If
For r = 1 To maxRows
arrB(r + RowSet, ToggleCol) = arrA(r, c + 1)
Next
isFirstRun = False
Next
Range("...").Resize(UBound(arrB, 1), UBound(arrB, 2)) = arrB 'set your outputrange here
End Sub
Add one line: Application.ScreenUpdating = False
Sub CutAndPasteColumnsUntilEmpty()
Dim lastRow As Long
Dim i As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
Do Until IsEmpty(Range("D2")) And IsEmpty(Range("E2"))
Range("D2:D" & lastRow).Cut Destination:=Range("B" & lastRow + 1)
Range("E2:E" & lastRow).Cut Destination:=Range("C" & lastRow + 1)
lastRow = ActiveSheet.UsedRange.Rows.Count
Columns("D:E").Delete
Loop
End Sub
I built a COVID model using UVA data. That data is currently unavailable so I've found another data source. Of course, the new data is not in the same format. So rather than starting from scratch, I'm importing the new data in the format the model was coded for. The new data looks like this...
The new data files are broken up into a Confirmed file, a Deaths file and a Recovered file. Each file is 267 rows and goes out to column EH with a new column added daily. I have a macro for each file. The Confirmed file takes about a minute - minute and a half to run. And when done it looks like this...
I don't import any of the confirmed = 0 data points. I've added the population/pop density columns to delete all the countries I don't care about (those with population = 0). This file has about 6800 rows and of course, this will also grow daily. When the Confirmed file is imported, of course the next thing is Deaths. When I try to import the Deaths file excel goes to 'Not Responding' state and doesn't finish. I've waited on the Deaths macro for about an hour before I killed it and it's still not done. I can see that the correct numbers are being put into the correct column in my consolidated file but it really shouldn't take so long or lock up excel like this. I realize that three For Loops is going through a lot of cells a lot of times. Is there a better way to do this?
Here is the Deaths import code:
Sub ImportCSSEDeaths()
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim lastrow As Long
Dim clastrow As Long
Dim lastcol As Long
Dim dte As Date
Dim filePath As String
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim cws As Excel.Worksheet
Set cws = ThisWorkbook.Sheets("Raw_Data")
lastrow = cws.Cells(Rows.count, "a").End(xlUp).Row
filePath = "C:\Users\chris.h\Desktop\COVID\Other_Data\CSSE\CSSE_Deaths.xlsx"
Set wb = Excel.Workbooks.Open(filePath)
Set ws = wb.Worksheets(1)
clastrow = cws.Cells(Rows.count, "b").End(xlUp).Row
lastrow = ws.Cells(Rows.count, "b").End(xlUp).Row
lastcol = ws.Cells(1, Columns.count).End(xlToLeft).Column
For i = 2 To clastrow
For j = 2 To lastrow
For k = 3 To lastcol
If cws.Cells(i, "a").Value = ws.Cells(j, "a").Value And _
cws.Cells(i, "b").Value = ws.Cells(j, "b").Value And _
cws.Cells(i, "c").Value = ws.Cells(1, k).Value Then
cws.Cells(i, "e").Value = ws.Cells(j, k).Value
cws.Cells(i, "e").NumberFormat = "#,##0"
End If
Next k
Next j
Next i
wb.Close False
End Sub
If more code is needed, I'll provide.
Thanks to #Tom and #Nacorid the following array based code works much faster! Only takes a min or two.
k = 0
For i = 2 To lastrow
For j = 3 To lastcol
'puts country row deaths into array
If ws.Cells(i, j).Value <> 0 Then
ReDim Preserve deaths(k)
deaths(k) = ws.Cells(i, j).Value
k = k + 1
End If
Next j
'finds startdate in new data
For j = 3 To lastcol
If deaths(0) = ws.Cells(i, j).Value Then
startDate = ws.Cells(1, j).Value
Exit For
End If
Next j
Debug.Print startDate
clastrow = cws.Cells(Rows.count, "b").End(xlUp).Row
'finds startdate in compiled data and enters array values down column e
For j = 2 To clastrow
If cws.Cells(j, "a").Value = ws.Cells(i, "a").Value And _
cws.Cells(j, "b").Value = ws.Cells(i, "b") And _
cws.Cells(j, "c").Value = startDate Then
count = j
For k = 0 To UBound(deaths)
cws.Cells(count, "e").Value = deaths(k)
count = count + 1
Next k
End If
Next j
Next i
I have a spreadsheet that contains data starting in row 2 column 1 and has 42 columns. I am trying to write a VBA code that will search all rows of my data starting with row 2 and if the value in column 32 is greater than 575, I need the code to insert enough rows below that row so that whatever the value was (whether it be 600 or 2,000) can be split into increments of 575. So for example, if row 5 column 32's value is 800, i want the code to add a row below row 5, and i want it to autofill the new row with the value of 575 in column 32 and replace the value in the original row with whatever it was minus 575. Also, in the first column of my data I have dates. For each new row that is created, I want it to be a week earlier than the date in the original row. Here is an example of what my data looks like:
Column1 ...Column 32.......Column 42
8/15/2019 // 3873
Here is what i want it to look like after I run the code.
Column1 ...Column 32......Column 42
8/15/2019 // 423
8/8/2019 // 575
8/1/2019 // 575
7/25/2019 // 575
7/18/2019 // 575
7/11/2019 // 575
7/4/2019 // 575
The slash marks are just there to show the separation in columns. And I want the data from all the other columns to stay the same as the row above. Is there a good way to do this?
This is the code I've come up with so far. However, the problem with it is I can't seem to figure out how to program it so that it know how many rows to add based on how large the quantity is. As of now, it just adds a row below any row that the value of column 32 is greater than 575. Also, it just adds blank rows. I don't have anything in my code that says what values to put in the newly created rows
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Col = "AF"
StartRow = 1
BlankRows = 1
LargeOrder = 575
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col).Value > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
As I mentioned before, I need the code to add however many rows needed to accommodate the original quantity to be broken into increments of 575, and also subtract a week with every row created. Thank you in advance for your help.
There are numerous way to achieve the objective. One is instead of reverse loop, you go down inserting balance amount and again on next row recalculated and so on till blank is encounters. May try the code tested with makeshift data
Option Explicit
Sub addLine()
Dim Col As Variant
'Dim BlankRows As Long
'Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AF"
StartRow = 2
'BlankRows = 1
LargeOrder = 575
R = StartRow
With Ws
ActNum = .Cells(R, Col).Value
Do While ActNum <> 0
If ActNum > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Range(.Cells(R, 1), .Cells(R, 42)).Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
'simpler calculation
Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, ActNum - LargeOrder)
'Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, Int(ActNum / LargeOrder) * LargeOrder - LargeOrder)
.Cells(R + 1, Col).Value = Balance
.Cells(R, Col).Value = ActNum - Balance
End If
R = R + 1
ActNum = .Cells(R, Col).Value
Loop
End With
End Sub
Edit: may try the modified code below for the variance in requirement
Option Explicit
Sub addLine2()
Dim Col As Variant
Dim LastRow As Long
Dim R As Long, i As Long
Dim StartRow As Long
Dim RowtoAdd As Long
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AS"
StartRow = 2
LastRow = Ws.Cells(Rows.Count, Col).End(xlUp).Row
R = StartRow
With Ws
Do
RowtoAdd = .Cells(R, Col).Value
LastRow = LastRow + RowtoAdd
For i = 1 To RowtoAdd
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, 1).EntireRow.Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
.Cells(R + 1, 32).Value = ""
R = R + 1
Next i
R = R + 1
Loop Until R > LastRow
End With
End Sub
In Column A, I have the below values from 1 to 20.
1. NBC997
2. EVO463
3. EVO426
4. EVO420
5. EVO826
6. EVO820
7. EVO863
8. CRO001
9. BCA915
10. SBH121
11. KEN500
12. GAM201
13. GAM1011
14. GAM101
15. SPR577
16. SPR580
17. SPR579
18. SPR576
19. DON201
20. MOR101
My formula below should be looking at column A and deleting the entire row if the left 2 characters <> "EV".
Once it finds one iteration it stops and doesn't go to the next line.
Sub remove()
Dim i As Long
For i = 1 To 20
If Left(Cells(i, "A"), 2) <> "EV" Then
Cells(i, "A").EntireRow.Delete
Else
End If
Next i
End Sub
I would not use the delete entire row. I would move the data up one row and then clear the contents of the last row.
Sub remove()
Dim i As Long
Dim x As Long
Dim lastCol As Long
Dim lastRow As Long
Const dataColumn As Long = 1
Const SearchPhrase As String = "EV"
Const firstRow As Long = 1
lastCol = Cells(firstRow, Columns.Count).End(xlToLeft).Column
lastRow = Cells(Rows.Count, dataColumn).End(xlUp).Row
x = 0
For i = lastRow To firstRow Step -1
If Left(Cells(i, dataColumn), Len(SearchPhrase)) <> SearchPhrase Then
If i = lastRow Then
Range(Cells(lastRow, dataColumn), Cells(lastRow, lastCol)).ClearContents
Else
Range(Cells(i, dataColumn), Cells(lastRow - 1 - x, lastCol)).Value = _
Range(Cells(i + 1, dataColumn), Cells(lastRow - x, lastCol)).Value
Range(Cells(lastRow - x, dataColumn), Cells(lastRow - x, lastCol)).ClearContents
End If
x = x + 1
End If
Next i
End Sub
I have to create a vba script that takes data from a column of another table in Excel ("Days Of Last Update", which is decimal), and then makes a sum based if the day are above 2 (showing the result in a new column).
It seems to be very simple, but I am a beginner and have no idea how to proceed.
UPDATE:
Hello everyone, thanks for the help. Now I have a new problem, still in this project. Here is what I've done:
The RawData's sheet have a column named "Days Since Last Update", that tells me when the Service Request of the product is updated. So, I created a new column with this formula =IF(N:N>2,1,0), to tells me if the Days Since Last Updated are above 2. I refreshed my pivot table to get this new column, did a Sum of the data, and get what I previously wanted, but, when the Update function of the worksheet run, the new column of the pivot table, as well as the column of the RawData with the formula, are gone. In the code (that isn't done by me) of the Update function, there was something like this:
Worksheets("Pivot table").PivotTables("PivotTable1").PivotCache.Refresh
It has something to do with my problem?
Please find the sample data sheet appended below.
VBA Code is appended below.
Sub Extract_Values()
Dim wks As Worksheet
Dim startRow As Integer
Dim lastRow As Integer
Dim vArray As Variant
Dim vNewArray As Variant
Dim i As Integer, j As Integer
Dim Counter1 As Integer, Counter2 As Integer
startRow = 2
Set wks = Sheets("Sheet1")
With wks
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
vArray = .Range("A" & startRow & ":D" & lastRow).Value2
For i = 1 To UBound(vArray)
If vArray(i, 4) = "Y" Then
Counter1 = Counter1 + 1
End If
Next i
ReDim vNewArray(1 To Counter1, 1 To 2)
For j = 1 To UBound(vArray)
If vArray(j, 4) = "Y" Then
Counter2 = Counter2 + 1
vNewArray(Counter2, 1) = vArray(j, 1)
vNewArray(Counter2, 2) = vArray(j, 2)
End If
Next
End With
Range("E" & startRow & ":F" & startRow + Counter1 - 1) = vNewArray
Range("E" & startRow & ":E" & startRow + Counter1 - 1).Select
Selection.NumberFormat = "m/d/yyyy"
Range("F" & startRow + Counter1).Select
End Sub
I am also a beginner setting proper VBA code in cell F8 which I have calculated Excel in-built Count Function.
COLUMN D Contains IF Formula like 'D2=IF(B2>1,"Y","N")'
HTH
Try
Dim RowCount As Integer
Dim NewRow As Integer
RowCount = 2
NewRow = 2
Do Until RowCount > Cells(2, 2).End(xlDown).Row
If Cells(RowCount, 2) > 1 Then
Range(Cells(NewRow, 5), Cells(NewRow, 6)).Value = Range(Cells(RowCount, 1), Cells(RowCount, 2)).Value
NewRow = NewRow + 1
End If
RowCount = RowCount + 1
Loop
End Sub