I'm new to VBA (somewhat) and I was assigned the tedious task of searching over 5000 rows to highlight rows (from A to j with the colorindex=6) based on a cell value and it's taking me forever. Basically I'm trying to develop a program that searches a string under column C, if the cell is equal to the string searched, then offset to 4 row below from the active cell and for any number greater than 37 and stops when it finds a cell in a row with the index color 33. Any ideas? I started and now stuck. Any ideas will help. Thanks
Sub Priority()
'Declaring all worksheets in the excel file
Dim US As Worksheet
Dim Venr50 As Worksheet
Dim Priority As Worksheet
Dim CBT As String
'setting all variables declared
Set US = Worksheets("US CKS")
Set Venr = Worksheets("VENR50 US 09.24")
Set Priority = Worksheets("Priority")
CBT = Priority.Range("$C$6").Value
With US
Dim x As Long
For x = 4 To 3000
If Cells(x, "C").Value = CBT Then
ActiveCell.Interior.ColorIndex = 33
ActiveCell.Offset(4, 0).Select
End If
You can do another loop within your For loop like below:
Dim x As Long
Dim j as integer
For x = 4 To 3000
If Cells(x, "C").Value = CBT Then
For j=1 to 4
If Cells(x+j,"C").Value>37 then Cells(x+j,"C").ColorIndex = 6
If Cells(x+j,"C").Interior.ColorIndex = 33 then exit sub
Next j
End If
If Cells(x+j,"C").Interior.ColorIndex = 33 Then Exit Sub
Next x
EDIT:
To change the color index of multiple rows you can use:
Range(Cells(x+j,"A"),Cells(x+j,"J")).Interior.ColorIndex = 6
Related
I'm having issues combining the VBA offset function within a loop. Essentially I am trying to extract multiple sets of values from a column of data based on a search term (survey value). I can get this to work for a single term, but I was hoping to create a macro that would extract all the values for all terms at once.
The set up of the data is a column (c6:c50) of raw data (indicators), and then 13 columns (j6:j50, m6:m50 etc) (output) where the extracted values should appear. columns K and L (and so on between the initial 13 columns) contain formulas based on the values of column J. the search term for each of the 13 columns is in the cell directly above the range (J5, M5 etc.).
The code below is where I have got to. The aim was to have a loop that extracts the values from column C into column J (the 'i'-based loop) and then a second loop ('j'-based loop) that offsets across the columns.
What happens when this is run is that the firstcell value in cell J6 fills, followed by the correct value in J7. Then all subsequent extracted values overwrite what was in J7. Once the loop for the first term is complete, it offsets by 3 columns, extracts the same value in J6 to M6 (presumably because the search term 'survey' is not offsetting?) but then goes back to overwriting cell J7.
Any help would be greatly appreciated.
Sub indicator_charts()
Dim indicators As Range
Dim survey As String
Dim surveyrng As Range
Dim output As Range
Dim survey2 As String
Dim firstcell As Range
Set indicators = Worksheets("Indicator Summary").Range("C6:C50")
Set output = Worksheets("Indicator Summary").Range("j5:j50")
Set surveyrng = Worksheets("Indicator Summary").Range("J5")
Set firstcell = Worksheets("Indicator Summary").Range("J6")
survey = surveyrng.Value
For j = 0 To 36 Step 3
output.Offset(0, j) = output
surveyrng.Offset(0, j) = surveyrng
firstcell.Offset(0, j) = firstcell
For i = 1 To 46
If InStr(1, indicators.Cells(i, 1).Value, survey) Then
survey2 = indicators.Cells(i, 1).Value
If IsEmpty(firstcell) Then
firstcell.Value = survey2
Else
output.End(xlDown).Offset(1, 0).Value = survey2
End If
End If
Next i
Next j
End Sub
I modified your code a bit. Should do what you want now.
Sub indicator_charts()
Dim indicators As Range
Dim survey As String
Dim surveyrng As Range
Dim output As Range
Dim survey2 As String
Dim firstcell As Range
Dim OutputVar As Variant
Dim SurveyRngVar As Variant
Dim FirstCellVar As Variant
Set indicators = Worksheets("Indicator Summary").Range("C6:C50")
Set output = Worksheets("Indicator Summary").Range("j5:j50")
Set surveyrng = Worksheets("Indicator Summary").Range("J5")
Set firstcell = Worksheets("Indicator Summary").Range("J6")
For j = 0 To 36 Step 3
Set OutputVar = output.Offset(0, j)
Set SurveyRngVar = surveyrng.Offset(0, j)
Set FirstCellVar = firstcell.Offset(0, j)
survey = SurveyRngVar.Value
For i = 1 To 46
If InStr(1, indicators(i, 1).Value, survey) Then
survey2 = indicators(i, 1).Value
If IsEmpty(FirstCellVar) Then
FirstCellVar.Value = survey2
Else
OutputVar.End(xlDown).Offset(1, 0).Value = survey2
End If
End If
Next i
Next j
End Sub
Suppose that I have Excel file consists of four worksheets, lets name them as 1, 2, 3 and 4. I want to evaluate a sum of all values from the cells AK10, AK25, AK40 and so on till AK160 on the worksheet 4 and then place it in the cell G23 of worksheet 2.
Here is my macro that I assign to worksheet 2:
Sub sum_up()
Dim i As Integer, s As Integer
s = 0
For i = 0 To 10
s = WorksheetFunction.Sum(s, Worksheets("4").Range("AK(10 + 15 * i)"))
Next i
Range("G23").Value = "s"
End Sub
It ends up with 400 error. What am I doing wrong?
Sub sum_up()
Dim i As Long, s As Long
s = 0
For i = 0 To 10
s = s + Worksheets("4").Cells(10 + 15 * i, "AK").Value
Next i
Range("G23").Value = s
End Sub
I'll take a crack at this - I'd really use a lot more named ranged to pass data back and forth...:
Sub sum_up()
Dim i As Integer, s As Integer
s = 0
For i = 0 To 10
s = s + Worksheets("4").Range("AK" & (10 + 15 * i))
Next I
Range("G23").Value = s
End Sub
you did not say that the summation was to be done using VBA
put this in G23 on worksheet2 (actually, put this in any cell)
=SUM('4'!AK10,'4'!AK25,'4'!AK40,'4'!AK55,'4'!AK70,'4'!AK85,'4'!AK100,'4'!AK115,'4'!AK130,'4'!AK145,'4'!AK160)
as far as what you are doing wrong with your code, that has partly been answered by #KenWhite
you are also putting the letter "s" into G23 of any worksheet that happens to be visible at the time your code runs
put in a reference to sheet 2, same as you referenced sheet 4 just two lines above
this code should work:
Sub sum_up()
Dim ws4 As Worksheet
Set ws4 = ActiveWorkbook.Sheets("4")
Dim rng As Range
Set rng = ws4.Range("ak10") ' point to "ak10"
Dim total As Long
total = rng.Value
Do While True
rng.Select
Set rng = rng.Offset(15) ' move pointer down 15 rows
If rng.Row > 160 Then Exit Do ' moved past row 160 ?
total = total + rng.Value
Loop
ActiveWorkbook.Sheets("2").Range("G23").Value = total
End Sub
I want to read and store values from 4*4 matrix(2 dimensional array) and use it in my further program. I am talking about VBA for Excel. Data is in Excel sheet and I want to read it through VBA. I am new to this, but learning fast. Please help me doing it.
this is my data in sheet
a 2 5 6
b 6 8 7
c 3 6 9
this is what I want to do
a 0 2 7 13
b 0 6 14 21
c 0 3 9 18
I need to read 3*3 matrix from sheet and transform it to cumulative matrix as shown. (add the previous number and go on).
Basically I am simulating a Markov Chain and needs to count how many times a person go through each stage.
Sub example7()
Dim A As Double, B As Double, C As Double, PC(4, 4) As Double, row As Double, maxrwo As Double, col As Double, maxcol As Double
Range("o5").Activate
For i = 1 To 4
For j = 1 To 4
PC(i, j) = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, -4).Select
Next i
Range("T4") = PC(2, 4)
End Sub
If you want to process values in a range you don't need to store them in an array first. You could loop through each cell in the range by using code similar to the below:
Sub LoopThroughRange()
Dim currentCell As Range
Dim desiredRange As Range
Dim outputCell As Range
Dim total As Double
Set outputCell = Range("A6")
Set desiredRange = Range("Sheet1!A1:D4")
'This will add the values of each cell in the range and output the total to cell A6
For Each currentCell In desiredRange
total = total + currentCell.Value
Next currentCell
outputCell.Value = total
End Sub
I am trying to get a For loop which copies an entire row from worksheet 1 to worksheet 3 if the cell in column C in ws1 and column AT in ws2 matches. I have two issues:
1. It seems to be stuck in the For i = xxxxx loop and does not move to the next k (only copies one line 25 times)
2. When I use it on a sheet that has 100,000 rows for worksheet 1 and 15,000 rows on worksheet 2, excel just crashes. Is there a way to manage this?
Sub CopyBetweenWorksheets()
Application.ScreenUpdating = False
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet, myVar As String, myVar2 As String
Set ws1 = Worksheets("BOM")
Set ws2 = Worksheets("APT")
Set ws3 = Worksheets("Combined")
'get the last row for w2 and w1
ii = ws1.Cells.SpecialCells(xlCellTypeLastCell).row
kk = ws2.Cells.SpecialCells(xlCellTypeLastCell).row
For k = 2 To kk
myVar = ws2.Cells(k, 46)
For i = 688 To ii '688 To ii
myVar2 = ws1.Cells(i, 3)
If myVar2 = myVar Then
ws3.Rows(k).EntireRow.Value = ws1.Rows(i).EntireRow.Value 'copy entire row
Exit For
End If
Next i
Next k
End Sub
Your code is fine (not mentioning the missing Application.ScreenUpdating = True), but it will hang on large number of rows and columns because of the amount of interations with the application (Excel in this case).
Each time you request a value from a single cell from Excel, your code will hang for about 4 secounds per 1 million requests. From an entire row it will hang for 4 secounds per 4000 requests. If you try writing a single cell, your code will hang for 4 secounds per 175000 requests, and writing an entire row will hang your code for 4 secounds per 300 requests.
This way, only if you try parsing 15.000 rows of data from one sheet to another, your code will hang for about 3,3 minutes.. not to mention all read requests..
So, always keep the amount of interactions with any application from vba to a minimum, even if you have to create a much bigger code.
Here is what your code should look like if you want to handle a lot of data:
Sub CopyBetweenWorksheets2()
Dim aAPT, aBOM, aCombined As Variant
Dim lLastRow As Long, lLastColumn As Long
Dim i As Long, j As Long
Const APTColRef = 3
Const BOMColRef = 46
Const MAXCol = 200
'Speed up VBA in Excel
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get the last row and column to use with the combined sheet
lLastRow = WorksheetFunction.Min(APT.Cells.SpecialCells(xlCellTypeLastCell).Row, BOM.Cells.SpecialCells(xlCellTypeLastCell).Row)
lLastColumn = WorksheetFunction.Min(MAXCol, WorksheetFunction.Max(APT.Cells.SpecialCells(xlCellTypeLastCell).Column, BOM.Cells.SpecialCells(xlCellTypeLastCell).Column))
'Parse all values to an array, reducing interactions with the application
aAPT = Range(APT.Cells(1), APT.Cells(lLastRow, lLastColumn))
aBOM = Range(BOM.Cells(1), BOM.Cells(lLastRow, lLastColumn))
'Creates a temporary array with the values to parse to the destination sheet
ReDim aCombined(1 To lLastRow, 1 To lLastColumn)
'Loop trough values and parse the row value if true
For i = 1 To lLastRow
If aAPT(i, APTColRef) = aBOM(i, BOMColRef) Then
For j = 1 To lLastColumn
aCombined(i, j) = aAPT(i, j)
Next
End If
Next
'Parse values from the destination array to the combined sheet
Combined.Range(Combined.Cells(1), Combined.Cells(lLastRow, lLastColumn)) = aCombined
'Disable tweaks
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
!! I named the sheets objects in the VBA itself, so you don't have to declare a new variable and you also won't have any problems if you rename them later. So, insted of sheets("APT"), I just used APT (you will have to rename it too if you want the code to work) !!
Plus, here is my speed code I wrote for speed testing my codes. I always keep it at hand, and use it in almost every function i write
Sub Speed()
Dim i As Long
Dim dSec As Double
Dim Timer0#
Dim TimerS#
Dim TimerA#
Dim TimerB#
dSec = 4 ''Target time in secounds''
i = 1
WP1:
Timer0 = Timer
For n = 1 To i
SpeedTestA
Next
TimerA = Timer
For n = 1 To i
SpeedTestB
Next
TimerB = Timer
If TimerB - Timer0 < dSec Then
If TimerB - Timer0 <> 0 Then
i = CLng(i * (dSec * 2 / (TimerB - Timer0)))
GoTo WP1
Else
i = i * 100
GoTo WP1
End If
End If
MsgBox "Código A: " & TimerA - Timer0 & vbNewLine & "Código B: " & TimerB - TimerA & vbNewLine & "Iterações: " & i
End Sub
Sub SpeedTestA() 'Fist Code
End Sub
Sub SpeedTestB() 'Secound Code
End Sub
Sub UpdateCSAH()
Dim S As String
Dim R As Long
Dim RR As Long
Dim CC As Long
Dim i As Long
Dim j As Long
Dim csah() As String 'an array that stores the CSAH sites
ReDim csah(1 To 100, 1 To 7)
Dim Ran As Range
Dim Ran1 As Range
Set Ran = Worksheets("Current Sites").Range("A1").CurrentRegion 'Ran is the region that has values
RR = 1 'row number in csah
CC = 1 'column number in csah
'check each value in Ran to see if its Route section has "CSAH"
For Each cell In Ran
R = cell.row
S = CStr(Cells(R, 4).value)
If InStr(S, "CSAH") > 0 Then 'check if "CSAH" is in the Route section
If CC > 7 Then 'reset the column number and go to the next row when reach the end of the column
CC = 1
RR = RR + 1
End If
csah(RR, CC) = cell.value
CC = CC + 1
End If
Next cell
Worksheets("CSAH Sites").Select
Range("A2:G100").Select
Selection.ClearContents
'assign each array values to cells in sheet"CSAH Sites"
i = 1
j = 1
For i = 1 To UBound(csah, 1)
For j = 1 To UBound(csah, 2)
Cells(i + 1, j) = csah(i, j)
Next j
Next i
'format the CSAH Sites values
Set Ran1 = Worksheets("CSAH Sites").Range("A1").CurrentRegion
For Each cell In Ran1
If cell.row = 1 Then
With cell.Font
.Color = -11489280
End With
ElseIf cell.row Mod 2 = 0 Then
With cell.Interior
.Color = 10092441
End With
End If
Next cell
End Sub
I have an Excel worksheet named "Current Sites" that has some data. If the 4th column has the word "CSAH", I want to store the values of that row into an array and assign those values to cells in the worksheet named "CSAH Sites". My code sometimes works (the 1st time you click), and most of times it doesn't work or doesn't work properly.
Please help me out! Thanks A Bunch!!
It looks like you want to check every row of data in the "Current Sites" sheet and if column 4 includes the "CSAH" text, then write the first 7 columns of data for that entry to the "CSAH Sites" sheet and add some colour to the even-numbered rows.
To check every row of data, you can read down just one column and use either the Offset or the Cells method to see the values of neighbouring cells. In your code you were "touching" every cell and each time you were then looking at the value in column 4 and also checking to see if the code had gone past column 7. That slows things down a lot and makes the code hard to understand.
You can also assign the values from a range of cells directly to another range of cells without using variables or an array.
See if this does what you want:
Sub UpdateCSAH()
Dim currentSitesRange As Range
Dim thisSiteRange As Range
Dim outputCell As Range
Dim numRowsOfData As Long
Const NUM_COLUMNS_OF_DATA As Integer = 7
Set currentSitesRange = Worksheets("Current Sites").Range("A1")
numRowsOfData = currentSitesRange.CurrentRegion.Rows.Count
Set currentSitesRange = currentSitesRange.Resize(RowSize:=numRowsOfData) 'currentSitesRange is the region that has values
Worksheets("CSAH Sites").Range("A2:G100").ClearContents
Set outputCell = Worksheets("CSAH Sites").Range("A2")
For Each thisSiteRange In currentSitesRange.Cells
' Look for "CSAH" in the Route section (column D)
If InStr(1, thisSiteRange.Offset(ColumnOffset:=3).Value, "CSAH", vbTextCompare) > 0 Then
' Found "CSAH" so write NUM_COLUMNS_OF_DATA columns of data to CSAH Sites sheet
outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value = thisSiteRange.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value
' Format the even-numbered rows
If outputCell.Row Mod 2 = 0 Then
With outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Interior
.Color = 10092441
End With
End If
Set outputCell = outputCell.Offset(RowOffset:=1)
End If
Next thisSiteRange
End Sub