I have a column with random values that has repeats data in a certain format:
Column 1
A
A
A
A
B
B
C
C
C
A
A
D
D
E
F
F
F
G
...
I tried using
Dim i As Integer
Dim noRows As Integer
'count rows
noRows = Range("B2:B10000").Rows.Count
'delete row entries that are duplicates..
For i = 1 To noRows
If Range("H2").Cells(i + 1, 1) = Range("H2").Cells(i, 1) Then
Range("H2").Cells(i + 1).Resize(1, 2).Clear
End If
Next i
Which I quickly realised would not work at all.
how could I write a code so the output would be:
Column 1
A
[..]
[..]
[..]
B
[..]
C
[..]
[..]
[..]
A
D
[..]
[..]
E
F
[..]
[..]
G
...
Where the [..]s are nulls or zero
Disregard the second "66.63" field which is green, it should be red
Keep the previous value in a variable and compare it against the cell's value.
Dim sPrv
Dim oRng
Dim i
sPrv = "" '<- previous value
Set oRng = ActiveSheet.Range("H2", ActiveSheet.Range("H2").End(xlDown)) '<- set range of one column starting from H2 to the end of row
Debug.Print oRng.Rows.Count '<- Row count.
For i = 1 To oRng.Rows.Count
Debug.Print i, sPrv, oRng.Cells(i,1), sPrv = oRng.Cells(i,1) '<- print counter, previous value, cell value, sPrv = Cell ?
If sPrv = oRng.Cells(i, 1) Then '<- current value the same as previous
oRng.Cells(i, 1).Value = "" '<- Set the cell value to blank
Else
sPrv = oRng.Cells(i, 1).Value '<- Keep the new value for the next comparison and leave the cell value as is
End If
Next
Try this it will work. I have created a fake column which will flag as 1 in that column just to identify the repeat.
Code:
Sub stack()
Dim s1 As Worksheet
Set s1 = Sheets("Sheet1")
For i = 2 To s1.Range("A1").End(xlDown).Row
If s1.Cells(i, 1).Value = s1.Cells(i - 1, 1) _
Then
s1.Cells(i, 2).Value = "1"
End If
Next
For j = 2 To s1.Range("A1").End(xlDown).Row
If s1.Cells(j, 2).Value = 1 Then
s1.Cells(j, 1).Value = "[..]"
End If
Next
s1.Columns("B").Delete
End Sub
Related
I've got a code that puts all the data of my Excel file (rows = 12,5k+ and columns = 97) in to a two-dimensional string. Then it loops through a certain column ("G") to list an listbox ("listbox1") with only unique findings.
Then in the Userform the user can choose to select some of the found items and transform it to another listbox ("Listbox2") Then when the user hits the button (CommandButton4) I would like the code to filter the array on only the rows where in column "G" it is the same as in one (or more) given criteria in listbox2.
It works when It has only one item in the listbox but when given two items in the listbox, it only returns everything blank.
Can some one please tell me what I'm doing wrong because I've no idea.
code:
Private Sub CommandButton4_Click()
Dim arr2() As Variant
Dim data As Variant
Dim B_List As Boolean
Dim i As Long, j As Long, q As Long, r As Long, LastColumn As Long, LastRow As Long
q = 1
r = 1
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet3")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ThisWorkbook.Sheets("Sheet3")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
LastColumn = .Cells(3, Columns.Count).End(xlToLeft).Column
ReDim arr2(1 To LastRow, 1 To LastColumn)
For i = 2 To LastRow
For j = 1 To LastColumn
arr2(i, j) = .Cells(i, j).Value
Next j
Next i
End With
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Sheets("Sheet3").UsedRange.ClearContents
For i = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(i, 2) <> "" Then
r = r + 1
For j = LBound(arr2, 2) To UBound(arr2, 2)
ThisWorkbook.Sheets("Sheet3").Cells(r, j).Value = arr2(i, j)
Next j
End If
Debug.Print i, j, arr2(i, 7)
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
The issue is your second nested-loop:
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Suppose that our ListBox has 2 values, "First" and "Second". For each row, you do the following:
j = 0
ListBox2.List(0) = "First"
If Column G is "First", do nothing
Otherwise, make the whole Row Blank Including if Column G = "Second"
At this point, the only possible values for Column G are now "First" or Blank
j = 1
ListBox2.List(1) = "Second"
If Column G is "Second", do nothing But, this cannot happen, because you have already changed any "Second" Rows to Blank
Otherwise, make the whole Row Blank
At this point, the Row will always be Blank
I recommend having a Boolean test variable. Set it to False at the start of each Row-loop, and set it to True if you find a match. If it is still False after you check all ListBox items, then blank the row:
Dim bTest AS Boolean
For i = 1 To LastRow
bTest = False 'Reset for the Row
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
bTest = True 'We found a match!
Exit For 'No need to keep looking
End If
Next j
If Not bTest Then 'If we didn't find a match
For q = 1 To LastColumn
arr2(i, q) = "" 'Blank the row
Next q
End If
Next i
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I have an Excel worksheet with the following format:
Club A Total: ## Club B Total: ## Club C Total: ##
Account Placement Account Placement Account Placement
Value: ## Value: ## Value: ##
Account Placement
Value: ##
Club D Total: ## Club E Total: ## Club F Total: ##
Account Placement Account Placement Account Placement
Value: ## Value: ## Value: ##
Account Placement
Value: ##
Account Placement
Value: ##
For any club, they may have more than one account placement added later on, aligned to respective column as above. My objective is to calculate the Total for each club, which will automatically account for all Account Placement under a club, with the calculation goes as:
Eg. Total of Club B = Value of Account Placement 1 + Value of Account Placement 2 + ...
Same goes with other clubs. I have managed to locate each club and the value of first account using the following code:
Dim ra As Range
For Each ra In ActiveSheet.UsedRange
If InStr(1, ra.Text, "Account Placement") > 0 Then
accvalue = Cells(ra.Row + 1, ra.Column + 1).Value
End If
Next ra
The above code finds "Account Placement" horizontally, ie. it will get 1st value of Club A, then 1st value of Club B, then 1st value of Club C, then 2nd value of Club B, then 1st value of Club D etc. with respect to the above illustrated worksheet layout.
This make it hard to get the sum of Value for each Club. How do you get around this problem? Any help is appreciated.
Yes. The trick is to scan top-down, not left-to-right:
Option Explicit
Sub GetAllTotals2()
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim c As Range, UL As Range
Dim ID As String, nextID As String
Dim lastcol As Long, lastrow As Long, v As Long
With ActiveSheet.UsedRange
Set UL = .Cells(1, 1)
Set c = .Cells(1, 1)
lastcol = UL.Column + .Columns.Count
lastrow = UL.Row + .Rows.Count
End With
ID = ""
While c.Column < lastcol
Set c = Cells(UL.Row, c.Column + 1) ' top of column
'check if column empty
If c.End(xlDown).Row < lastrow Then
' scan "value" column for values; check for ID change!
While c.Row <= lastrow
If Left(c.Text, 5) = "value" Then
v = c.Offset(0, 1).Value
nextID = c.Offset(-2, -1)
' may check nextID, needs to be "Club x"...
If nextID <> "" Then ID = nextID ' ID changed
If dict.Exists(ID) Then
dict(ID) = dict(ID) + v
Else
dict.Add ID, v
End If
Set c = c.Offset(2, 0) ' skip next 2
End If
Set c = c.Offset(1, 0) ' row-wise
Wend
End If
Wend
' show
Dim key
For Each key In dict
Debug.Print key & " " & (dict(key))
Next key
End Sub
Using while loops is not optimal in regard to performance. The code shown already skips empty columns as a start. I thank user1274820 for the dictionary code which fits perfectly for this task.
edit:
With working code I thought about optimizations. Scanning all used cells (plus backtracking) leads to the worst possible performance. The following code works by scanning columns top-down only if it contains the "value" keyword which is checked by simply counting it. Furthermore, the cell pointer is not incremented by one but jumps to the next non-empty cell.
Sub GetAllTotals3()
Const keyword As String = "value:" ' got to be EXACT
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim c As Range, UL As Range
Dim ID As String, nextID As String
Dim lastcol As Long, lastrow As Long, v As Long
With ActiveSheet.UsedRange
Set UL = .Cells(1, 1)
Set c = .Cells(1, 1)
lastcol = UL.Column + .Columns.Count
lastrow = UL.Row + .Rows.Count
End With
ID = ""
While c.Column < lastcol
' check if column not empty
If WorksheetFunction.CountIf(c.EntireColumn, keyword) > 0 Then
' scan "value" column for keyword; check for ID change!
While c.Row <= lastrow
If c.Text = keyword Then
v = c.Offset(0, 1).Value
nextID = c.Offset(-2, -1)
' may check nextID, needs to be "Club x"...
If nextID <> "" Then ID = nextID ' ID changed
If dict.Exists(ID) Then
dict(ID) = dict(ID) + v
Else
dict.Add ID, v
End If
End If
' optim.: jump down to next filled cell
Set c = c.End(xlDown)
Wend
End If
' go right to next column, start at top
Set c = Cells(UL.Row, c.Column) ' top of column
Set c = c.End(xlToRight) ' optim.: jump right to next filled cell
Wend
' show
Dim key
For Each key In dict
Debug.Print key & ": " & (dict(key))
Next key
End Sub
Based on #user1274820's answer, I made a little adjustment.
Sub GetAllTotals()
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim ra As Range
Dim rollback As Integer 'Additional variable
For Each ra In ActiveSheet.UsedRange
If InStr(1, ra.Text, "Account Placement") > 0 Then
rollback = -1
'Rolling back number of rows to locate the Club ID
Do Until ra.Offset(rollback,-1).Value <> ""
rollback = rollback -1
Loop
With ra.Offset(rollback, -1)
If dict.Exists(.Value) Then
dict(.Value) = dict(.Value) + ra.Offset(1, 1).Value
Else
dict.Add .Value, ra.Offset(1, 1).Value
End If
End With
End If
Next ra
Dim c
For Each c In dict
Debug.Print c & " " & (dict(c))
Next c
End Sub
Like magic, everything fall perfectly into place.
I want to copy the end of the column B and C in worksheet 1
To column B and C in worksheet 2
I have this :
and this is above :
And here is the code
'Copy of "Maintenances" in worksheet 2
n = 58 'start to look row 58
j = 2 'copy in row 2 in worksheet 2
Sheets("1").Select 'select sheet 1
Do While Cells(n, 1) <> "x" 'do for each cells untill there is a "x" in column A
If Cells(n, 1) <> "x" Then 'if column A is empty, then :
Sheets("2").Cells(j, 2) = Sheets("1").Cells(n, 2) '
Sheets("2").Cells(j, 3) = Sheets("1").Cells(n, 3) '
j = j + 1
End If 'fin du if
n = n + 1
Loop 'retourne au do while
I want to copy all row Under "maintenance" in worksheet 2, BUT the row of "maintenance" can change. the problem is not when the row is ending, but when it start. In my code, it copies column B and C between 58 and when there is a "x" in column 1. but I want that the copy start when in column B its "maintenance"
If I understand your question correctly, then you may replace n = 58 'start to look row 58 with the following code to determine the value of variable n as a start row.
Dim WordToFind As String, FirstWord As String
Dim FindWord
WordToFind = "Maintenance"
With Sheets("1").Range("A:C")
Set FindWord = .Find(what:=WordToFind, SearchDirection:=xlNext)
If Not FindWord Is Nothing Then
FirstWord = FindWord.Row
Do
n = FindWord.Row + 1 'The value of n start from the row below "Maintenance"
Exit Do
Loop While Not FindWord Is Nothing And FindWord.Row <> FirstWord
Else
MsgBox "There is no word " & WordToFind
Exit Sub
End If
End With
You can change the value WordToFind depending on a word or string you are looking for.
I have a created the below loop to search for any value beginning with "R" plus a special character which is 10 characters long and paste these into the next blank cell on column 1 on another sheet.
I now need to develop this code to copy any values beginning with R on sheet2 and paste these into column 1 (A) on sheet1 and copy any value beginning with a numeric digit on sheet2 and paste these into column 4 (D) on sheet1
The "R" Value would be associated to the Numeric Value. For example, on sheet2 A1 could be R000000_01 and B1 (If a value is present) could be 12345 these two need to be copied into A3 and D3 as mentioned above
This is what I have created so far:
EnvRange = "A2:R999"
RowNo = 3
For Each C In Worksheets("Sheet2").Range(EnvRange)
If Len(C.Value) < 10 Then
GoTo NextCell
ElseIf Len(C.Value) < 11 Then
Worksheets("Sheet1").Cells(RowNo, 1).Value = C
RowNo = RowNo + 1
Else
Chars = InStr(1, C, "R")
Do While Chars < Len(C)
Worksheets("Sheet1").Cells(RowNo, 1).Value = Mid(C, Chars, 10)
Chars = InStr(Chars + 9, C, "R")
RowNo = RowNo + 1
If Chars = 0 Then GoTo NextCell
Loop
End If
NextCell: Next C
Your help in this matter would be very much appreciated.
Thank you in advance.
You can use Like to check the format:
Sub Tester()
Const ENV_RNG As String = "A2:R999"
Dim c As Range, RowNo As Long, sht As Worksheet
Set sht = Worksheets("Sheet1")
RowNo = 3
For Each c In Worksheets("Sheet2").Range(EnvRange)
If c.Value Like "R?????????" Then
sht.Cells(RowNo, 1).Value = c.Value
sht.Cells(RowNo, 4).Value = c.Offset(0, 1).Value
RowNo = RowNo + 1
End If
Next c
End Sub