I'm having trouble with my loop not running throughout my entire sheet 1. If the value in Sheet 1 "tests" exist in sheet 2 "cancer". Then i want the value in sheet 2 "cancer" to be placed into sheet 1 "Tests". The code works except for the loop. Currently it only applies to the first record in my first sheet then stops.
Sub Testing()
Dim x As Long
Dim y As Long
x = 2
y = 2
Do While Sheets("Cancer").Cells(y, 1).Value <> ""
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) Then
If Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
x = x + 1
End If
End If
y = y + 1
Loop
End Sub
I would use two for loops
for y = 2 to 10000 'the range your values are found
if Sheets("Cancer").Cells(y, 1).Value <> "" then
for x = 2 to 10000 'the range your values are in
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
End If
next
end if
next
The reason for the loop not running throughout the entire sheet 1 is because of these two lines:
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = ""
If these conditionals aren't both true, then x will never loop to its next iteration, and you'll have gone through looping through each value of Sheet2 "Cancer" while checking only the same record of Sheet1 "Tests".
You've almost qualified all of your ranges. You missed one. Try changing the line:
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
to
Sheets("Tests").Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
Related
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
The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
Cant seem to figure out why my code is not showing output. New VBA programmer only know basics so any help would be helpful.
What I want is for Excel to start checking a specific column for a specific text1 and then start copying and pasting those values till it reaches text2. After that I want it to check the next fifth column in the same manner.
If you could suggest modifications to my code.
Without putting in a for loop for the column my code looks like this.
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If Cells(x, y).Value = "text1" Then 'check first for specific text
Do Until Cells(x, y).Value = "text2" 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else
x = x + 1 'if not on that row then check the next row
End If
End Sub
Really hard to see what is going wrong here as your code should be doing what you want.
The only other thing that could throw your results is when you have different case ,as VBA will treat a string with an upper case character as being different, so you may not actually be entering the loop at all. And I am assuming that text1 is just a sample string for the question.
So comparing the string in lower case will ensure that if you have any upper case characters they will be compared correctly, using the LCase function should help with that.
Full code,
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If LCase(Cells(x, y).Value) = LCase("text1") Then 'check first for specific text
Do Until LCase(Cells(x, y).Value) = LCase("text2") 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else: x = x + 1 'if not on that row then check the next row
End If
End Sub
Kind of hard to see the big picture but I think I produced the result you want with:
Sub FindText()
Dim textFound As Range
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 0 'first row
a = 70 'this is the row where i want the data to be posted
Set textFound = ActiveSheet.Columns(y).Cells.Find("Text1")
Do Until textFound.Offset(x, 0).Value = "Text2"
Cells(a + x, y).Value = textFound.Offset(x, 0).Value
Cells(a + x, y + 1).Value = textFound.Offset(x, 1).Value
x = x + 1
Loop
End Sub
This code is far from perfect but should work in most circumstances.
I have a excel sheet looks like this: "Sheet1" & "Sheet2" and I wanted the result as shown in "Sheet3".
Sample Data
Eventually I would like to put a "Button" in a separate sheet (Control Panel) and when clicking on it I need to combine the data from "Sheet1" and "Sheet2" with the transpose effect as shown in "Sheet3".
How can I automate this using macro since there are ~2000 "rows" in Sheet 1 and ~1000 in Sheet 2. I'm new to macro so hopefully I can make this automated otherwise I'm copying and pasting all of them manually.
Thanks!
It might be helpful to use a function that returns the last row of a worksheet:
Public Function funcLastRow(shtTarget As Worksheet, Optional iColLimit As Integer = -1) As Long
If iColLimit = -1 Then
iColLimit = 256
End If
Dim rowMaxIndex As Long
rowMaxIndex = 0
Dim ctrCols As Integer
For ctrCols = 1 To iColLimit
If shtTarget.Cells(1048576, ctrCols).End(xlUp).Row > rowMaxIndex Then
rowMaxIndex = shtTarget.Cells(1048576, ctrCols).End(xlUp).Row
End If
Next ctrCols
funcLastRow = rowMaxIndex
End Function
You could use it simply like so:
Dim lLastRow As Long
lLastRow = funcLastRow(Sheets(1))
Please let us know if that worked for you thanks
Here is an all formula solution (No Macro)
Data is in Sheet1 A to I and Sheet2 A to G
I am assuming you have only 6 departments. although if you have additional, the formulas need very little or may be no modification.
In Sheet 3
Get the userID repeated six times
A2 = INDEX(Sheet1!A:A,1+QUOTIENT(ROW()-ROW($A$2)+6,6))
Get Name, Gender & Country
B2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:B$1),FALSE)
C2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:C$1),FALSE)
D2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:D$1),FALSE)
Get Access to department. The "" & ... is to avoid 0 in case the resulting cell was blank.
E2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,HLOOKUP(F2,Sheet1!$A$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0),FALSE),HLOOKUP(F2,Sheet2!$A$1:$G$3000,MATCH(A2,Sheet2!$A$1:$A$3000,0),FALSE))
F2:F7 the departments are Input manually (no formula). F8 is linked to F2 so that the depts repeat when dragged down
G2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,INDEX(Sheet1!$I$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)),INDEX(Sheet2!$G$1:$G$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)))
If you need, I can prepare a google sheet to demo. Cheers.
This code works very well for Transpose and concatenate of big data.
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub
I'm working on a project where I have sales data broken down into quarters. What I need to do is in front of each column insert the three months that belong in that quarter. I started with a select case statement, but then realized that probably isn't the best way to do it. What I want to do is have it be a variable range (there can be anything from 1-10 years pasted in) so I set it up to search InStr for "Q1", "Q2" and then insert the rows and proper month titles. I haven't inserted month titles yet, because I want to get the rows inserted first, but if you have a suggestion on how to do that without specifying cell values that'd also be awesome! it's also worth mentioning this data insertion starts on column U and will every time. Thanks for any help or suggestions!
Sub InsertMonths()
If cell.value = InStr(1, cell, "Q1", 1) Then
Dim y As String
y = InStr(1, cell, "Q1", 1)
If y = "" Then Exit Sub
Dim x As Long
For x = Cells(Columns.Count, 1).End(xlUp).Column To 1 Step -1
If Cells(x, 18).value = y Then
Columns(x + 3).Resize(1).Insert
End If
Next x
Else cell.value = InStr(1, cell, "Q2", 1) Then
Dim y As String
y = InStr(1, cell, "Q2", 1)
If y = "" Then Exit Sub
Dim x As Long
For x = Cells(Columns.Count, 1).End(xlUp).Column To 1 Step -1
If Cells(x, 18).value = y Then
Columns(x + 3).Resize(1).Insert
End If
Next x
Else InStr(1, cell, "Q3", 1) then
Dim y As String
y = InStr(1, cell, "Q3", 1)
If y = "" Then Exit Sub
Dim x As Long
For x = Cells(Columns.Count, 1).End(xlUp).Column To 1 Step -1
If Cells(x, 18).value = y Then
Columns(x + 3).Resize(1).Insert
End If
Next x
Else InStr(1, cell, "Q4", 1) then
Dim y As String
y = InStr(1, cell, "Q4", 1)
If y = "" Then Exit Sub
Dim x As Long
For x = Cells(Columns.Count, 1).End(xlUp).Column To 1 Step -1
If Cells(x, 18).value = y Then
Columns(x + 3).Resize(1).Insert
End If
Next x
End If
End Sub
Without coming into too much detail in the exact situation, here you have a couple of loops doing the same than your set of conditions. It is prepared to deal with as many cells as required (letters and ints).
Sub InsertMonths()
Dim startInt, endInt, totLetters, lettersCount, curInt As Integer
Dim allLetters(10), curLetter, curCell As String
totLetters = 1
allLetters(1) = "Q"
startInt = 1
endInt = 4
lettersCount = 0
Do
lettersCount = lettersCount + 1
curLetter = allLetters(lettersCount)
curInt = startInt - 1
Do
curInt = curInt + 1
curCell = curLetter & CStr(curInt)
If cell.Value = InStr(1, cell, curCell, 1) Then
Dim y As String
y = InStr(1, cell, curCell, 1)
If y = "" Then Exit Sub
Dim x As Long
For x = Cells(Columns.Count, 1).End(xlUp).Column To 1 Step -1
If Cells(x, 18).Value = y Then
Columns(x + 3).Resize(1).Insert
End If
Next x
End If
Loop While (curInt < endInt)
Loop While (curLetter < totLetters)
End Sub
In your code, where you are setting the value in the cell to hold the month, put the following formula instead of the value
Cells(x, y).value = "=(MID($D2,2,1) - 1) * 3 + 1"
Second column would be
Cells(x, y).value = "=(MID($D2,2,1) - 1) * 3 + 2"
And third would be
Cells(x, y).value = "=(MID($D2,2,1) - 1) * 3 + 3"
In all of the cases above, the $D2 should reference the cell you found to contain the "Q#". The formulas are basically taking the numerical part of the quarter and calculating the 1st, 2nd and 3rd months of the quarter.
Also note that this gives you the month number. If you want the name, you should be able to figure that out.