I get a file I want to process via a macro in excel.
Column A holds values from 1-10
Column C holds a value in C1
For each value 6 in column A, the corresponding cell in Column C in the same row should be updated with a sequentially incremented value starting from the value in C1.
I had something like below, but that gave many issues, but it shows the concept I am looking for.
Sub customernumberext()
Dim a As Range, i As Long
Range("C1").Select
If ActiveCell.Value <> Empty Then
i = "C1"
For Each a In ActiveSheet.Range("a:a") where a.value = "6"
row c = i
i = i + 1
Next a
Else: MsgBox ("no number present")
End If
End Sub
If I am reading your description and errant code correctly, this should solve the problem.
Sub incr_C()
Dim rw As Long, lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 2 To lr
If .Cells(rw, 1).Value = 6 Then
.Cells(rw, 3) = Application.Max(Range("C1:C" & rw - 1)) + 1
End If
Next rw
End With
End Sub
Related
I am pretty new to macros. Just need to do this small task at work.
Overview: I am running two different recipes/programs to generate data.
Every alternate row is a reading generated from different recipe. I want to compare the last two rows in the same sheet. If the values have a standard deviation of more than 0.5, I need to report or change the colors of the cells. How do I do that?
I wrote the following but it did not work for me:
Sub checkit()
Row1length = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Row1length
If Worksheets("Sheet1").Cells(7, i).Value <> Worksheets("Sheet1").Cells(8, i) Then
Match = False
Exit For
End If
Next
If Match = True Then
Debug.Print "match"
Else
Debug.Print "not match"
End If
End Sub
This code will loop through all the rows in the sheet and compare the first with the second, marking cells which have different values.
Sub CheckIt()
Const FirstDataRow As Long = 2 ' change as required
Dim Rl As Long, Cl As Long
Dim R As Long, C As Long
With Worksheets("Sheet1") ' change the sheet name
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Cl = .Cells(FirstDataRow, .Columns.Count).End(xlToLeft).Column
For R = FirstDataRow To Rl Step 2
For C = 1 To Cl
If (.Cells(R, C).Value) <> (Cells(R + 1, C).Value) Then
Range(.Cells(R, C), Cells(R + 1, C)).Interior.Color = vbYellow
End If
Next C
Next R
End With
End Sub
I'm not sure where I'm going wrong. I'm trying to compare values within a column ("B") to a cell referenced to ("A1"). If the values in Column "B" equal "A1" I want it to count up. When it gets to the end of Column "B" I'm trying to get it to loop back and compare values in column "B" with "A2", etc. For example:
So Far I've written two different codes one with a nested do while loop and a nested do while if loop but i cant get them to loop through the whole column
Sub CountDb()
Dim i As Long
Dim iRow As Long
Dim initial As Long
i = 1
iRow = 1
initial = 1
Do While Cells(iRow, "A").Value <> "" 'initial loop, whilst there are values in cell "A" continue the loop
Do While Cells(i, "B").Value = Cells(iRow, "A").Value 'nested while loop, comparing the first B1 and cell A1.
If True Then Cells(i, "C") = initial 'if they A1 and B1 are equal, print 1 in column C
initial = initial + 1 'and move on comparing A1 with B2
If False Then
i = i + 1 'if not satisfied, move on to cell B2 etc.
Loop
iRow = iRow + 1 'when you get to the end of column B, start again and compare values with A2 and B
Loop
End Sub
Sub CountDb()
Dim i As Long
Dim iRow As Long
Dim initial As Long
'same comments as above, just different methodology
i = 1
iRow = 1
initial = 1
Do While Cells(iRow, "A").Value <> ""
If Cells(i, "B").Value = Cells(iRow, "A").Value Then
Cells(i, "C") = initial
Else
initial = initial + 1
i = i + 1
End If
iRow = iRow + 1
Loop
End Sub
Any help would be appreciated. Thanks!
*EDIT - fixed up column references
**EDIT - applied comments to code
Try this instead:
Option Explicit
Sub test()
Dim sht As Worksheet
Dim lastrow As Long, i as integer, j as integer, initial as integer
Set sht = Workbooks("Book1").Worksheets("Sheet1") 'Don't forget to change this
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
initial = 1
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For j = 1 To lastrow
If Workbooks("Book1").Worksheets("Sheet1").Range("A" & i).Value = Workbooks("Book1").Worksheets("Sheet1").Range("B" & j).Value Then
Workbooks("Book1").Worksheets("Sheet1").Range("C" & j).Value = initial
initial = initial + 1
End If
Next j
Next i
End Sub
I prefer using For loops as opposed to Whiles, just because I can see the ranges being looped through more easily. Here we use nested For loops, the first to loop through column A, the second to loop through column B. If our value in column A equals our value in column B, we place the initial number in column C using our variable from the nested loop.
Notice how to make this work, we re-initialize our lastrow variable to make the ranges for our loops.
It is useful to use countif.
Sub test()
Dim rngOrg As Range, rngDB As Range
Dim Wf As WorksheetFunction
Dim vR() As Variant
Dim i As Long, n As Long
Set Wf = WorksheetFunction
Set rngOrg = Range("a1", Range("a" & Rows.Count).End(xlUp))
Set rngDB = Range("b1", Range("b" & Rows.Count).End(xlUp))
n = rngDB.Rows.Count
ReDim vR(1 To n, 1 To 1)
For Each Rng In rngDB
i = i + 1
If Wf.CountIf(rngOrg, Rng) Then
vR(i, 1) = Wf.CountIf(Range("b1", Rng), Rng)
End If
Next Rng
Range("c1").Resize(n) = vR
End Sub
Here is another method, this time using Find. This is probably quicker than the looping method since it leverages the in-built find function to skip to the next match.
I've commented the code below for clarity, but basically we loop through values in column A (using a For loop because they're less prone to disguised infinite looping than While) and look for them in column B.
Note: This looks a bit longer, but that's mainly because (a) I've added lots of comments and (b) I've used a With statement to ensure the ranges are fully qualified.
Sub countdb()
Dim c As Range, fnd As Range, listrng As Range, cnt As Long, addr As String
' Use with so that our ranges are fully qualified
With ThisWorkbook.Sheets("Sheet1")
' Define the range to look up in (column B in this case)
Set listrng = .Range("B1", .Range("B1").End(xlDown))
' Loop over values in the index range (column
For Each c In .Range("A1", .Range("A1").End(xlDown))
cnt = 0
' Try and find the c value
Set fnd = listrng.Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues, after:=listrng.Cells(listrng.Cells.Count))
If Not fnd Is Nothing Then
' Store the address of the first find so we can stop when we find it again!
addr = fnd.Address
' Loop over all other matches in the range. By using a "Do ... Loop While"
' style loop, we ensure that the loop is run at least once!
Do
' Increase count and assign value to next column
cnt = cnt + 1
fnd.Offset(0, 1).Value = cnt
' Find next match after current
Set fnd = listrng.Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues, after:=fnd)
Loop While fnd.Address <> addr
End If
Next c
End With
End Sub
The trick is in making the declarations transparent. After that the programming is very easy.
Sub CountMatches()
Dim Rng As Range ' "count" range (= column "B")
Dim Itm As String ' item from the "items' column (= "A")
Dim Rla As Long, Rlb As Long ' last row in columns A and B
Dim Ra As Long, Rb As Long ' row counters
Dim Counter As Long ' count matches
With ActiveSheet
' look for the last used rows
Rla = .Cells(.Rows.Count, "A").End(xlUp).Row
Rlb = .Cells(.Rows.Count, "B").End(xlUp).Row
' start looking for matches from row 2
Set Rng = .Range(.Cells(2, "B"), .Cells(Rlb, "B"))
' start looping in row 2
For Ra = 2 To Rla
Itm = .Cells(Ra, "A").Value
If Len(Trim(Itm)) Then ' skip if blank
' start comparing from row 2
For Rb = 2 To Rlb
' compare not case sensitive
If StrComp(.Cells(Rb, "B").Value, Itm, vbTextCompare) = 0 Then
Counter = Counter + 1
End If
Next Rb
.Cells(Ra, "C").Value = Counter
Counter = 0
End If
Next Ra
End With
End Sub
Now the question is whether the transparency that workred for me appears transparent to you. I hope it does. :-)
This should be significantly faster.
Sub CountMatches_2()
Dim Rng As Range ' "count" range (= column "B")
Dim Itm As String ' item from the "items' column (= "A")
Dim Rla As Long, Rlb As Long ' last row in columns A and B
Dim Ra As Long, Rb As Long ' row counters
With ActiveSheet
' look for the last used rows
Rla = .Cells(.Rows.Count, "A").End(xlUp).Row
Rlb = .Cells(.Rows.Count, "B").End(xlUp).Row
' start looking for matches from row 2
Set Rng = .Range(.Cells(2, "B"), .Cells(Rlb, "B"))
' start looping in row 2
For Ra = 2 To Rla
Itm = .Cells(Ra, "A").Value
If Len(Trim(Itm)) Then ' skip if blank
.Cells(Ra, "C").Value = Application.CountIf(Rng, Itm)
End If
Next Ra
End With
End Sub
This code presumes that each item in column A is unique. If it is not duplicates will be created which, however, it would be easy to eliminate either before or after they are created.
First post here so bear with me. It's possible something similar to what I am going to ask has been posted but my technical illiteracy might have prevented me from finding it.
I have a column of data ~45,000 cells.
Within these cells lie descending data of individuals identified by an ID#, followed by anywhere from 1-8 additional cells with criteria relevant to the preceding ID#.
What I'm trying to do it convert this large column to a row for each of the ~5,500 IDs.
Here is an example of what I'm trying to achieve
I come from a beginner level SAS background and have only used Excel previously in a very brief manner, and have been trying to figure this out off and on for a week or two now. I've started transposing them manually but that is going to take forever and I hope there's an easier way.
My best guess would be, from what I've seen so far, that a VBA code could be written, but I don't know where to start with that. I'm also open to any other ideas on how to achieve the result I'm trying to get.
Thanks in advance!
Sub TransposeData()
Dim Data, TData
Dim x As Long, x1 As Long, y As Long
With Worksheets("Sheet1")
Data = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
ReDim TData(1 To UBound(Data, 1), 1 To 8)
For x = 1 To UBound(Data, 1)
'If the Data macthes the ID pattern (7 Digits) then
'increment the TData Row Counter
If Data(x, 1) Like "#######" Then
x1 = x1 + 1
y = 0
End If
'Increment the TData Column Counter
y = y + 1
TData(x1, y) = Data(x, 1)
Next
With Worksheets("Sheet2")
With .Range("A" & .Rows.Count).End(xlUp)
If .Value = "" Then 'If there is no data, start on row 1
.Resize(x1, 8).Value = TData 'Resize the range to fit the used elements in TData
Else ' Start on the next empty row
.Offset(1).Resize(x1, 8).Value = TData
End If
End With
End With
End Sub
If I correctly understand your problem the following code should solve it;
Sub ColToRow()
Dim inCol As Range
Set inCol = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8) 'Get the input column as a range
Dim outCol As Range
Set outCol = inCol.Offset(0, 2) 'Set the output column as a range
Dim index As Long 'Current row
Dim cell As Range 'Current cell
Dim lastRow As Long 'The last row
Dim currRow As Long 'Current output row
Dim currCol As Long 'Current output column
lastRow = inCol.SpecialCells(xlCellTypeLastCell).Row
currRow = inCol.Row - 1
currCol = 0
For index = inCol.Row To lastRow
Set cell = ActiveSheet.Cells(index, inCol.Column) 'Set the cell range to the current cell
If Application.WorksheetFunction.IsNumber(cell) And Len(cell.Value) = 7 Then 'If numeric then we assume it is the ID, else we assume it is the
currRow = currRow + 1 'Advance to next output row
currCol = 0 'Reset column offset
cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy ID
ElseIf currRow > 0 Then 'Ensure we are within the row bounds and not at 0 or below
currCol = currCol + 1 'Advance the column
cell.Copy Destination:=ActiveSheet.Cells(currRow, outCol.Column + currCol) 'Copy Text Values until we get the next numeric value
End If
Next index 'Advance the row
End Sub
The code simply goes (in order) down the column and does the following;
- If the cell has a numeric value then we assume it is the ID and create a new row.
- If the cell has a text value we just add it to the next column in the current row, it'll continue to do this with however many string values until a new ID is reached.
Hope it helps.
-Regards
Mark
Another possible solution, based on ID being 7 digits numbers and all other numbers being not
Option Explicit
Sub main()
Dim area As Range
Dim iArea As Long
With ThisWorkbook.Worksheets("Transpose") '<--| reference relevant worksheet (change "Transpose" to your actual sheet name)
With .Range("A1", .Cells(.Rows.COUNT, 1).End(xlUp).Offset(1))
.Cells(.Rows.COUNT, 1).Value = 1111111 '<--| add a "dummy" ID to end data
.AutoFilter Field:=1, Criteria1:=">=1000000", Operator:=xlAnd, Criteria2:="<=9999999" '<--| filter its "JobCol_Master" named range on textbox ID
.Cells(.Rows.COUNT, 1).ClearContents '<--| remove "dummy" ID
With .SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
For iArea = 1 To .Areas.COUNT - 1
Set area = .Parent.Range(.Areas(iArea), .Areas(iArea + 1).Offset(-1))
.Parent.Cells(.Parent.Cells.Rows.COUNT, 3).End(xlUp).Offset(1).Resize(, area.Rows.COUNT).Value = Application.Transpose(area.Value)
Next iArea
End With
End With
End With
End Sub
I have lists of different value in column A and B which contents same value for several rows respectively. like the following:
BEFORE
column A | column B
1. a b
2. a b
3. a b
4. a b
5. z z
6. z z
7. z z
8. z z
AFTER
column A | column B
1. a b
2.
3.
4.
5. z z
6.
7.
8.
How do I delete the duplicate cell with former rows cell in same column? Like the After.
I have done the following so far:
Sub clear()
Dim x
Dim c
x = 1
c = Range("a1").Value
Do Until Cells(x, 1) = ""
If Cells(x, 1) = Cells(x + 1, 1) Then
Cells(x + 1, 1) = Range().ClearContents
End If
Loop
End Sub
Try this:
Option Explicit
Sub clear()
Dim cRow As Long
Dim CellValue As String
cRow = 2 ' start the loop in row 2
CellValue = Range("a1").Value
Do Until Cells(cRow, 1) = ""
If Cells(cRow, 1) = CellValue Then
Cells(cRow, 1).ClearContents
Cells(cRow, 2).ClearContents ' clear column B cell
Else
CellValue = Cells(cRow, 1) ' when the cell value changes,
End If
cRow = cRow + 1 ' increment the row number so the next loop goes to the next row
Loop
End Sub
I prefer variables with descriptive names over x and c.
Some issues with your code were:
Range must have a parameter, but you don't need Range when you already have the cell object with Cells()
you did not increment the variable that sets the row
the cleared cell became the new current cell and since it had just been cleared, the loop would end
you never used the c variable, but it is useful to keep a record of the comparison string.
you may want to consider the following "array" approach should speed be an issue:
Option Explicit
Sub main()
Dim i As Long, j As Long
Dim myArr As Variant, refVal As Variant
With Worksheets("MySheet") '<--| change "MySheet" with your actual sheet name
With Intersect(.UsedRange, .Columns("A:B")) '<--| consider only columns A and B rows down to the worksheet used range last one
myArr = .Value ''<--| store values in array
For j = LBound(myArr, 2) To UBound(myArr, 2) '<--| loop through array columns
refVal = myArr(1, j) '<--| get column fiurst reference value
For i = LBound(myArr, 1) + 1 To UBound(myArr, 1) '<--| loop through form current column 2nd row downwards
If myArr(i, j) = refVal Then '<--| if there's a duplicate...
myArr(i, j) = "" '<--| ...erase it
Else '<--| otherwise...
refVal = myArr(i, j) '<--| ... get the new non duplicate value as the reference one
End If
Next i
Next j
.Value = myArr '<--| write back array to worksheet
End With
End With
End Sub
using Option Explicit statement is a safe habit that at the cost of some little extra work to declare all variables pays you back with much more control over your code and much less issues in debugging and maintaining it
using full range reference (like Worksheets("MySheet").Range(...)) is a good habit to avoid issues due to user sheet jumping selections
To complement the answers from teylyn and user3598756, you could work from bottom to top to check the values:
Public Sub myClear(Optional ByRef wks As Worksheet = Nothing)
Dim c As Range
Dim col As Long
If wks Is Nothing Then Set wks = ActiveSheet
For col = 1 To 2 'Columns A and B
Set c = wks.Cells(wks.Rows.Count, col).Rows.End(xlUp)
Do While c.Row > 1
If c.Value = c.Offset(-1, 0).Value Then c.ClearContents
Set c = c.Offset(-1, 0)
Loop
Next col
End Sub
The sub will work by default on the ActiveSheet, but you can give in parameter the actual sheet you want to work on.
I'm working on cleaning up timesheets for an Access database, and I'm having issues with cleaning up the data.
I have a time sheet with names in the first column, then all of the columns after that, from C to M (or so) have hours. What I am trying to accomplish is that when the Macro finds a name in the first column, it selects the columns in that row, finds the cells without hours, and fills them with zeroes
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
Next
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next
I'm attempting to loop and fill rows with zeroes based on the cell having a named entered in it. The problem that I'm running into is that cells are only being filled in the last name/row in the spreadsheet. The macro seems to be skipping over all but the last row.
I'm just learning VBA, so maybe I'm just missing something in the syntax.
Thanks for the help!
The problem is that you are moving on to the next selection, all the way to the last row, before you start filling in your 0s. Try this modification to your code:
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
Using this method, you fill in the 0s before moving on to the next selection/row.
Note: I avoid the use of .select/Selection because of the problems it can cause, so I am not sure if you will receive an error message if a row does not contain a name. If you wish to avoid this potential error, try the below:
Dim r As Integer
Dim c As Range
Dim c2 As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Set c2 = Range(Cells(r, 3), Cells(r, 10))
End If
For Each c In c2
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
By the way, did you strip out the Workbook and Sheet names from Range(Cells(r, 3), Cells(r, 10)) to simplify your post? I was surprised you were able to use that without errors. If so, you'd obviously have to put them back in for my code to work.
possibly,
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeConstants)
Rng = 0
End Sub
You want to take all of the blank cells and turn them into zeroes.
Sub zeroed_hours()
Dim rw As Long
With Sheets("Sheet1") '<-set this worksheet reference properly!
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If CBool(Len(.Cells(rw, 1))) Then 'found a name!
'C:M on this row
.Cells(rw, 3).Resize(1, 11).Replace what:="", replacement:=0, lookat:=xlWhole
End If
Next rw
End With
End Sub
This loops through the cells in column A. If it finds a value (something with length greater than zero) then it replaces all blank cells in C:M on that row with zeroes.