I have solved this problem myself thanks to the people who offered help
I have an if statement which relies on a counter, I am taking the value of the counter from cell "B3" and the code works fine as it is.
However each time I loop through the program I need the counter to take it's value from a different cell.
so for example loop 1 read value from "B3"
loop 2 read value from "C3"
next "D3" and so on across the sheet
keep going until it reaches a an empty cell
I have dim c as integer
and for c= 2 to 26 to take me to the 26th column
but I am not sure how to get it to increment each time the loop starts. can anyone help with this? I can post the full code I am using at the moment if that will help the understanding of the question
Public Sub copyX()
Dim listofcells As Range
Dim currentname As String
Dim foundrow As Integer
Dim foundcolumn As Integer
Dim counter As Integer
Dim i As Integer
Dim c As Integer
For i = 2 To 26
Sheets("Availability").Activate
counter = Range("b3")
Sheets("Availability").Range("a2").Select
If Not Sheets("Availability").Cells(2, i) = "" Then
Sheets("Availability").Range(Cells(2, i), Cells(2, i).End(xlDown)).Select
Else
GoTo skip: 'If the column has no data then skip to next column
End If
Set listofcells = Selection
Sheets("allocation").Activate
Range("a2").Select
For Each singlecell In listofcells
If counter > 0 Then
If singlecell = "Available" Then
foundcolumn = singlecell.Column 'record the column number where "Available" was found
currentname = Sheets("availability").Range("A" & singlecell.Row) 'record the name of the person in the row where "Available" was found
Set foundName = Sheets("allocation").Range("A:A").Find(What:=currentname, LookIn:=xlValues) 'find the persons name in "Allocation" sheet
foundrow = foundName.Row
Sheets("allocation").Cells(foundrow, foundcolumn) = "X" 'place yes in the same cell as it appeared in "Availability" sheet
counter = counter - 1
End If
End If
Next singlecell
skip:
Next i
End Sub
I have come up with the following code which does go through the cells and get their value, the problem is I can not get a for next loop to work inside another for next loop.
Set counterrange = Range("b3:Z3")
For Each cell In counterrange
Next cell
Try with this concept ...
modify your code to
Dim k as Integer
k=3;
counter =Range(Cells(3, k), Cells(3, k)).Value // through this you will get dynamic counter value like B3,D3,E3.,,,,
if(counter !="")
{
//execute some code
}
k=k+1;
Related
This is my code I have 2 problems.
The code all works fine but it needs to check if the cell that it is about to write to in "Allocation" holds the value "X1" or "X" if it does then it needs to go to the next person in the list, the peoples names are held in column A. I have solved this bit myself so it is just the last question I need help with now
Each time the loop starts the program needs to check who the last person to be allocated was and start the next allocation from the next persons name in the list of names. If it would help I could post the whole workbook so you can see what it is all doing but you would have to tell me how to do it as I can't seem to find a way of attaching a file. Thank you for looking and any help that may be offered
Public Sub copyothers()
Dim listofcells As Range
Dim currentname As String
Dim foundrow As Integer
Dim foundcolumn As Integer
Dim counter As Integer
Dim i As Integer
Dim personcount() As Variant
Sheets("Availability").Activate
personcount = Sheets("Availability").Range("B3:AR3").Value 'check the
number of people required in each column and record it for later
For i = 2 To 44
Sheets("Availability").Activate
Sheets("Availability").Range("a2").Select
counter = personcount(1, i - 1) - 1 'take the first number reduce
it by 1 and move one column right right each time program loops
If Not Sheets("Availability").Cells(2, i) = "" Then
Sheets("Availability").Range(Cells(2, i), Cells(2,
i).End(xlDown)).Select
Else
GoTo skip: 'If the column has no data then skip to next column
End If
Set listofcells = Selection
Sheets("allocation").Activate
Range("a2").Select
For Each singlecell In listofcells
If counter > 0 Then
If singlecell = "Available" Then
foundcolumn = singlecell.Column 'record the column number where
"Available" was found
currentname = Sheets("Availability").Range("A" & singlecell.Row)
'record the name of the person in the row where "Available" was
found
Set foundName =
Sheets("Allocation").Range("A:A").Find(What:=currentname,
LookIn:=xlValues) 'find the persons name in "Allocation" sheet
foundrow = foundName.Row
If Sheets("allocation").Cells(foundrow, foundcolumn) = ""
Then
Sheets("allocation").Cells(foundrow, foundcolumn) = "X"
'place X in the same cell as it appeared in "Availability" sheet
counter = counter - 1
End If
End If
End If
Next singlecell
skip:
Next i
End Sub
Image form Availability Sheet
Image form Allocation Sheet
I need to display a message box when all the values in a range on my spreadsheet are zero. Currently I am using the following code:
Dim Cell As Range
For Each Cell In Range("E17:E25")
If Cell.Value = "0" Then
MsgBox ("If hardware is required, please manually populate the corresponding sections.")
End If
Next
The message is displayed, however it is shown 9 times (for each of the cells in the range). What I need is to check if all the values in the range E17:E25 are zero, and then display only one message box. Any ideas?
Thanks.
You want to know if all the values are 0? You could just do
If WorksheetFunction.Sum(Range("E17:E25")) = 0 Then MsgBox ("If hardware is required, please manually populate the corresponding sections.")
No need for loops.
Edit: If you want to check for any other number, and if all cells are that number, you can do this:
Sub t()
Dim rng As Range
Dim myNum as Long
myNum = 1
Set rng = Range("B3:B6")
If WorksheetFunction.CountIf(rng, myNum) = rng.Count Then MsgBox ("All the same!")
End Sub
And cause there are infinite ways to skin a cat here is another approach.
Dim Cell As Range
Dim ZeroCount As Integer
Dim CellCount As Integer
ZeroCount = 0
CellCount = 0
For Each Cell In Range("E17:E25")
CellCount = CellCount + 1
If Cell.Value = 0 Then ZeroCount = ZeroCount + 1
Next Cell
If ZeroCount = CellCount Then MsgBox ("If hardware is required, please manually populate the corresponding sections.")
To test that:
The range doesn't contain any empty values
All cells are the same
function
Function SameRange(rngIn As Range) As Boolean
If Application.CountA(rngIn) = rngIn.Cells.Count Then SameRange = (Application.CountIf(rngIn, rngIn.Cells(1).Value) = rngIn.Cells.Count)
End Function
test
Sub test()
MsgBox SameRange([d1:d5])
End Sub
'something like this
Dim isDataPresent as boolean
isDataPresent = true
for each Cell in Range(....)
if cell.value = "0" then
isDataPresent = false
exit for
end if
next
if not isDataPresent then
show message box here
end if
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
What I am trying to do is iterate through a range containing worksheet names, and if the cell is not empty then add the result of CountA function to the count variable.
So the count variable should be equal to number of non-blank cells in range B9:B28 on the worksheets I'm iterating through, but strangely the value is equal to the number of non empty cells in the range I'm going through (sheet1!d5:d24).
What am I doing wrong? Here's the code I am using:
For Each c In Worksheets("Sheet1").Range("d5:d24").Cells
If Not IsEmpty(c) Then
count = count + WorksheetFunction.CountA(c & "!b9:b28")
End If
Next
I tried an alternative method to loop through second range and if the cells are not empty, then increment the variable by 1 but that's giving a Run time error 13 type mismatch error. This is what I am doing now:
For Each c In Worksheets("Sheet1").Range("d5:d24")
If Not IsEmpty(c) Then
For Each c2 In Worksheets(c).Range("b9:b28")
If Not IsEmpty(c2) Then
'count = count + WorksheetFunction.CountA(c & "!b9:b28")
count = count + 1
End If
Next
End If
Next
Please help me out. Thanks a lot in advance to all those who take out time to reply.
Based on #Peter Albert and #Peter L. 's comments, finally got it working. The correct code is:
For Each c In Worksheets("Sheet1").Range("d5:d24").Cells
If Not IsEmpty(c.Value) Then
count = count + WorksheetFunction.CountA(c.Value & "!b9:b28")
End If
Next
Thanks a lot guys :)
Try this:
Sub CountColBForColD()
Dim c As Range
Dim r As Long 'row counter
Dim rngB As Range
Dim rngD As Range
Dim lookSheet As Worksheet
Set rngD = Sheets("Sheet1").Range("D5:D24")
Set rngB = Range("B9:B28")
r = 1
For Each c In rngD
If Not IsEmpty(c) Then
On Error GoTo InvalidSheetName
Set lookSheet = Sheets(rngB(r).Value)
On Error GoTo 0
Count = Count + WorksheetFunction.CountA( _
lookSheet.Range(rngB.Address))
c.Offset(0, 1).Value = Count
r = r + 1
End If
NxtC:
Next
Exit Sub
InvalidSheetName:
Err.Clear
MsgBox "Sheet named in " & rngB(r).Address & " does not exist.", vbInformation
Resume NxtC
End Sub
I am using Microsoft Excel to keep track of tasks. I use a different "sheet" for each job. The structure is with regards to columns and data. I have been trying to create a VBA script that would accomplish the following:
Search sheets 1 - X for a value of "Open" or "Past Due" in a row
Copy all rows with those values into a single sheet (such as a ledger) starting at row 3 (so I can add the headers of the template)
Add a column A with the sheet name so that I know what job it came from.
Run this to my hearts obsessive compulsive behavior pleasure to update with new items
I have been using the following posts to help guide me:
Search a specific word and copy line to another Sheet <- which was helpful but not quite right...
Copying rows to another worksheet based on a search on a grid of tags <-- also helpful, but limited to the activesheet and not looping correctly with my modifications...
The last two evenings have been fun, but I feel like I may be making this harder than necessary.
I was able to create a VBA script (edited from another post here) to sweep through all the worksheets, but it was designed to copy all data in a set of columns. I tested that and it worked. I then merged the code base I was using to identify "Open" or "Past Due" in column C (that worked for only the activesheet) into the code. I marked up my edits to share here. At this point it is not functioning, and I have walked myself dizzy. Any tips on where I fubar-ed the code would be appreciated. My code base I working from is:
Sub SweepSheetsCopyAll()
Application.ScreenUpdating = False
'following variables for worksheet loop
Dim W As Worksheet, r As Single, i As Single
'added code below for finding the fixed values on the sheet
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim h As Long 'h replaced i variable from other code
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
'insert below row match search copy function
For Each cell In Range("B1:L1").Offset(r - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
' original code Rows(r).Copy Destination:=Sheets(2).Rows(j)
Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
j = j + 1
End If
toCopy = False
'Next
'end above row match search function
'below original code that copied everything from whole worksheet
' If W.Cells(r, 1) > 0 Then
' Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
' ThisWorkbook.Worksheets("Summary").Cells(i, 1)
' i = i + 1
' End If
Next r
End If
Next W
End Sub
The working code base to sweep through all the sheets was:
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
And the copy the matched data from the Activesheet is as follows:
Sub customcopy()
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
For Each cell In Range("B1:L1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
End Sub
You should look into this Vba macro to copy row from table if value in table meets condition
In your case, you would need to create a loop, using this advanced filter to copy the data to your target range or array.
If you need further advice, please post your code, and where you are stuck with it.