If and DoUntil VBA code wont display output - vba

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.

Related

Identifying missing data in a range

I'm looking to set up a VBA macro which automatically runs through a list of data in a column and picks out the missing values. The code I've got at the moment (see below) works, but I believe it starts looking in cell A2. I'd like it to start in B1.
How could I make this change?
Apologies, I'm a beginner to VBA!
Sub Check_Sequential()
Dim LR As Long, i As Long
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
ALR = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
x = 2
Cells(1, 3) = "Missing Numbers"
For i = 2 To LR
0
If Cells(i, 1) <> x Then
Cells(ALR, 3) = x
ALR = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
x = x + 1
Else
x = x + 1
End If
If Cells(i, 1) > x Then GoTo 0
If Cells(i, 1) = x Then
x = x + 1
End If
Next i
MsgBox "Done"
End Sub
In order to move from cell A2 to B1 for the search start range you would need the following changes to your code. This just addresses the area you defined your initial search:
Sub Check_Sequential()
Dim LR As Long, i As Long
LR = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row '// Changed from "A" to "B"
ALR = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
x = 2
Cells(1, 3) = "Missing Numbers"
For i = 1 To LR '// Chaged i to one to start at row 1 instead of 2
0
If Cells(i, 2) <> x Then '// Changed from i,1 to i,2
Cells(ALR, 3) = x
ALR = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
x = x + 1
Else
x = x + 1
End If
If Cells(i, 2) > x Then GoTo 0 '// Changed from i,1 to i,2
If Cells(i, 2) = x Then '// Changed from i,1 to i,2
x = x + 1
End If
Next i
MsgBox "Done"
End Sub
This should allow your code to work, although as a few others pointed out there are a few things you could look into to further develop your VBA skills:
Declare all variables with a type this will make your code more readable and stop them defaulting to variant (Eg ALR)
Avoid using 0 as a line name as "On Error GoTo 0" is how you restore to default error handling and this could be misleading
It is clearer to edit the cells value by using the ".value" property and it would work exactly the same in this case
It might be worth clearing your output column before writing as this code will stack the output on top of the older ones, not sure if this is intend though.
Although it was not a bad piece of code especially consider you classify yourself as a beginner.
My dear friend Steven Roman tells us that Cells is not an "official" collection or object... but it is really useful. Cells is equivalent to Application.Cells and Activesheet.Cells.
Cells(1,2) is equivalent to Range("B1"). I like Cells() better than Range() because it can take integer variables for row and column like your i and x, while Range doesn't like that.

VBA Loop from another sheet

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))

If and Do Until Loop EXCEL VBA

New to VBA if someone could help me what im doing wrong here.
Trying to run a loop such that it looks for a specific text, starts the loop then stops at a specific point.
The loops is such that I want it to copy some values below in my sheet hence a is 55.
Im facing the error Block IF without End If
Here is the code:
Private Sub CommandButton3_Click()
For y = 1 To 15 Step 5
Dim x As Double
Dim a As Double
x = 1
a = 55
If Cells(x, y).Value = "Text1" Then
Do Until Cells(x, y).Value = "Text2"
Cells(a, y) = Cells(x, y).Value
Cells(a, y + 1) = Cells(x, y + 1)
x = x + 1
a = a + 1
Loop
End Sub
Indenting is the way forward, you have a for statement with no next and an if with no End If:
Private Sub CommandButton3_Click()
For y = 1 To 15 Step 5
Dim x As Double
Dim a As Double
x = 1
a = 55
If Cells(x, y).Value = "Text1" Then
Do Until Cells(x, y).Value = "Text2"
Cells(a, y) = Cells(x, y).Value
Cells(a, y + 1) = Cells(x, y + 1)
x = x + 1
a = a + 1
Loop
End If
Next y
end sub
Besides the issues I mentioned in the comments to your post, if I understood you correctly, you want to loop on cells at Column A, find the first "Text1", then copy all the cells to row 55 and below, until you find "Text2". If that's the case, try the code below :
Private Sub CommandButton3_Click()
Dim x As Long, y As Long
Dim a As Long
Dim LastRow As Long
With Worksheets("Sheet1") '<-- modify "Sheet1" to your sheet's name
For y = 1 To 15 Step 5
x = 1 '<-- reset x and a (rows) inside the columns loop
a = 55 '<-- start pasting from row 55
LastRow = .Cells(.Rows.Count, y).End(xlUp).Row
While x <= LastRow '<-- loop until last row with data in Column y
If .Cells(x, y).Value Like "Text1" Then
Do Until .Cells(x, y).Value = "Text2"
.Cells(a, y).Value = .Cells(x, y).Value
.Cells(a, y + 1).Value = .Cells(x, y + 1).Value
x = x + 1
a = a + 1
Loop
End If
x = x + 1
Wend
Next y
End With
End Sub

Excel Macro Transpose only few columns

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

Inserting month columns before quarters

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.