Offset function on selective columns in Excel VBA - vba

Bit new to VBA. It seems quite simple though; am not able to figure it out how to use Offset function and While/Do while loop here.
I am making an excel form where columns A to L will have values.
Out of which few columns are mandatory. Those are A, B, C, D, F, G, H, I, J, L.
Which means those can't be left blank and other columns can be blank.
My excel looks like below.
I have written a code where it checks whether mandatory columns have values or not.
The code is as below :
Dim celadr, celval As Variant
Dim cell As Variant
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
On Error GoTo 0
shname = ActiveSheet.Name
Dim celArray, arr, Key1, KeyCell As Variant
celArray = ("A,B,C,D,F,G,H,I,J,L")
arr = Split(celArray, ",")
For Key1 = LBound(arr) To UBound(arr)
KeyCell = arr(Key1)
Range(KeyCell & "2:" & KeyCell & "" & LastRow).Select
'Selection.Clearformats
For Each cell In Selection
celadr = cell.Address
celval = cell.Value
If celval = "" Then
Range(celadr).Interior.Color = vbRed
strErr = Range(celadr).Value
Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = IIf(strErr = "", "Empty Found", strErr)
strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0)
Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _
strstr, TextToDisplay:=IIf(strErr = "", "Empty Found", strErr)
End If
Next cell
Next Key1
The result of this code is;
1) between each two school records a row may be left blank.
My above code will color such all rows also in red background.
(It should not happen)
2) Columns B, C, D, F, G, H can have values only in the same row in which school_name is mentioned.
So, if following rows for same school are left blank then those also will be colored in red background.
(It should not happen).
So; I want to make small correction to code:
I want to add a condition to code:
"When there is a value in Column A; then only the above code should be exceuted."
I tried to achieve it as I have written in below Code. Still, am not upto.
I have commented all such lines of code which were giving me error (from below code):
Dim celadr, celval, celadr1, celval1 As Variant
Dim cell, cell1 As Variant
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
On Error GoTo 0
shname = ActiveSheet.Name
Dim celArray, arr, Key1, KeyCell As Variant
'Range("A2:A" & LastRow).Select
'For Each cell1 In Selection
'celadr1 = cell1.Address
'celval1 = cell1.Value
'Do While Len(celval1) >= 1
celArray = ("A,B,C,D,F,G,H,I,J,L")
arr = Split(celArray, ",")
For Key1 = LBound(arr) To UBound(arr)
KeyCell = arr(Key1)
Range(KeyCell & "2:" & KeyCell & "" & LastRow).Select
'Selection.Clearformats
For Each cell In Selection
celadr = cell.Address
celval = cell.Value
' May be another loop over here to increment value in offset function according to column number.
If celval = "" Then 'And Offset Function Referring to column A, same row.
Range(celadr).Interior.Color = vbRed
strErr = Range(celadr).Value
Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = IIf(strErr = "", "Empty Found", strErr)
strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0)
Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _
strstr, TextToDisplay:=IIf(strErr = "", "Empty Found", strErr)
End If
' End If
Next cell
Next Key1
' Loop
Can someone guide me how I can make correct use of offset function/while loops here?
Edit:
Assume, XYZ School don't have value for No. of Teachers
And
PQRS School don't have value for No. of students
My Current output is as in below image:
Where as Expected Output is:

I think the below code should work - try it out and let me know if there are any issues:
Sub Your_Macro()
Dim celArray, item As Variant
Dim LastRow, x As Long
LastRow = Cells(rows.Count, "A").End(xlUp).row
celArray = ("A,B,C,D,F,G,H,I,J,L")
celArray = Split(celArray, ",")
For x = 2 To LastRow
If Not IsEmpty(Cells(x, "A")) Then
For Each item In celArray
If IsEmpty(Cells(x, item)) Then
Cells(x, item).Interior.Color = vbRed
End If
Next item
End If
Next x
End Sub

Related

How to make multiple "for" statements run efficiently in VBA

In my code there is a searching order and it does as folloing:
It takes each value (about 2000 ranges) in ws.sheet range A and looks it up in another sheet named wp.sheet range A (about 90 ranges). If a particular value x in ws.sheet range e.g A3 is not found in wp.sheet range A the next search order in sheet ws.sheet is the value y in the next range B3 (same row as value x) to be searched in sheet wp.sheet in the entire range B, and so on.
This is what my "for" loop does and the issue with my code is that it takes very long as it compares each value in ws.sheet range A1-2000 to the values in wp.sheet range A1-90. Is there an alternative which does it more quickly or more efficiently?
Dim wb As Workbook, wq As Object
Dim ws, wi As Worksheet, datDatum
Dim w As Long, I As Long, t As Long
Dim DefaultMsgBox()
Dim r, i As Integer
For r = 2 To 2000
Check = True:
For i = 1 To 90
If ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
For i = 1 To 90
If ws.Range("B" & r).Value = wp.Sheets("ABC").Range("B" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
For i = 1 To 90
If ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
NextR:
If Not Check = ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("B" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
MsgBox "......"
End If
Next r
End sub
I would suggest turning off ScreenUpdating and using the Find function instead:
Dim cell, foundValue, lookupRange As Range
Set wp = ThisWorkbook.Sheets("ABC")
Set ws = ThisWorkbook.Sheets("WS")
r = 2
number_r = 2000
ru = 1
number_ru = 90
Application.ScreenUpdating = False
'Loop through each cell in WS, offsetting through columns A to C
For Each cell In ws.Range("A" & r & ":A" & number_r)
For i = 0 To 2
'Define range to look up in ABC
Set lookupRange = wp.Range(wp.Cells(ru, i + 1), wp.Cells(number_ru, i + 1))
'Look for current WS cell on corresponding column in ABC
Set foundValue = lookupRange.Find(cell.Offset(0, i).Value)
'If cell is found in ABC...
If Not foundValue Is Nothing Then
Select Case i
Case 2 'If found cell is in column C
Do 'Lookup loop start
'If same values on columns D...
If foundValue.Offset(0, 1).Value = cell.Offset(0, 3).Value Then
'Copy data to WS and switch to the next cell
wp.Rows(foundValue.Row).Columns("E:AB").Copy
ws.Range("G" & cell.Row).PasteSpecial
GoTo nextCell
'If not same values on columns D...
Else
'Try to find next match, if any
Set foundValue = lookupRange.FindNext(foundValue)
If foundValue Is Nothing Then GoTo noMatchFound
End If
Loop 'Repeat until WS values in column C and D match ABC values in columns C and D
Case Else 'If found cell is in column A or B
'Copy data to WS and switch to the next cell
wp.Rows(foundValue.Row).Columns("E:AB").Copy
ws.Range("G" & cell.Row).PasteSpecial
GoTo nextCell
End Select
End If
Next i
noMatchFound:
MsgBox "......" 'Message appears only when no match was found in column A, column B and column C + D
nextCell:
Next cell
Application.ScreenUpdating = True
I hope you don't mind my saying so, but your code is hard to follow, including your choice of variable names. I can recommend that if you do not make use of your .copy statements, then comment them out and your code will run much faster.

Find the cell adresses for each cell that starts with a specific number

I am looking for a code, that can find each cell that starts with the number "2347" in column L. I want to get the cell adresses for these cells and display it in a MessageBox for example "Msgbox: Cells L3500:L3722 has a value starts starts with "2347" "
Sub Findrow()
Dim MyVal As Integer
Dim LastRow As Long
MyVal = LEFT(c.Value,4) = "2347" _
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For Each c In Range("L2:L" & LastRow)
If c.Value = Myval Then
This is my code so far. Hope someone can help me!
Using arrays is quite fast
Option Explicit
Public Sub FindIDInColL()
Const VID = "2347" 'Value to find
Dim ws As Worksheet, arrCol As Variant, found As Variant
Set ws = ActiveSheet 'Or Set ws = ThisWorkbook.Worksheets("Sheet3")
arrCol = ws.Range(ws.Cells(2, "L"), ws.Cells(ws.Rows.Count, "L").End(xlUp))
ReDim found(1 To UBound(arrCol))
Dim r As Long, f As Long, msg As String
f = 1
For r = 1 To UBound(arrCol) 'Iterate vals in col L, excluding header row
If Not IsError(arrCol(r, 1)) Then 'Ignore errors
If Len(arrCol(r, 1)) > 3 Then 'Check only strings longer than 3 letters
If Left$(arrCol(r, 1), 4) = VID Then 'Check first 4 letters
found(f) = r + 1 'Capture rows containing value (header offset)
f = f + 1
End If
End If
End If
Next
If f > 1 Then 'If any cells found
ReDim Preserve found(1 To f - 1) 'Drop unused array items
msg = "Cells in col L starting with """ & VID & """" & vbNewLine & vbNewLine
MsgBox msg & " - L" & Join(found, ", L"), , "Total Found: " & f - 1
Else
MsgBox "No cells starting with """ & VID & """ found in col L", , "No matches"
End If
End Sub
Even faster when using the string versions of these functions
Left$() Mid$() Right$() Chr$() ChrW$() UCase$() LCase$()
LTrim$() RTrim$() Trim$() Space$() String$() Format$()
Hex$() Oct$() Str$() Error$
They are more efficient (if Null is not a concern), as pointed out by QHarr
You may try this:
Option Explicit
Sub Findrow()
Dim MyVal As String ' "2347" is a String
Dim LastRow As Long
Dim c As Range, myCells As Range
MyVal = "2347"
LastRow = cells(Rows.Count, "L").End(xlUp).row
Set myCells = Range("M2") 'initialize cells with a dummy cell certainly out of relevant one
For Each c In Range("L2:L" & LastRow)
If Left(c.Value2, 4) = MyVal Then Set myCells = Union(myCells, c) ' if current cell matches criteria then add it to cells
Next
If myCells.Count > 1 Then MsgBox "Cells " & Intersect(myCells, Range("L:L")).Address(False, False) & " have values starting with ‘2347’" ' if there are other cells than the dummy one then get rid of this latter and show their addresses
End Sub

Excel VBA - How to concatenate data in multiple dynamic number of rows and multiple columns [closed]

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 5 years ago.
Improve this question
I want to concatenate the data dynamically using Excel VBA Macro and have no idea how to handle the data spread over varying number of rows and multiple columns.
Here is the image of sample data and output required... (Click to enlarge.)
Assuming that:
Each new row required in the output begins in the sample data with a serial number. However in the sample data the number of rows for each output data varies, as in the image you see, the first output row is spread over 3 rows in sample data, similarly the second and third output rows are spread over 5 rows and 4 rows in the sample data.
The columns A, B, C, D should have their output in column M
The columns E, F should have their output in column N
The columns G, H should have their output in column O
The columns I, J, K should have their output in column P
I need dynamic VBA code which prompts for:
Number of output columns
Output column begins with column__
Input column range for each output column.
Here is the code which I have worked out, to concatenate the range with empty cells in between, where the input range and output cell is selected manually.
Sub Concatenate()
'Creates a basic CONCATENATE formula with no options
Call Concatenate_Formula(True, True)
End Sub
Sub Concatenate_Formula(bConcat As Boolean, bOptions As Boolean)
Dim rSelected As Range
Dim c As Range
Dim sArgs As String
Dim bCol As Boolean
Dim bRow As Boolean
Dim sArgSep As String
Dim sSeparator As String
Dim rOutput As Range
Dim vbAnswer As VbMsgBoxResult
Dim lTrim As Long
Dim sTitle As String
'Set variables
Set rOutput = ActiveCell
bCol = False
bRow = False
sSeparator = ""
sTitle = IIf(bConcat, "CONCATENATE", "Ampersand")
'Prompt user to select cells for formula
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to create formula", _
Title:=sTitle & " Creator", Type:=8)
On Error GoTo 0
'Only run if cells were selected and cancel button was not pressed
If Not rSelected Is Nothing Then
'Set argument separator for concatenate or ampersand formula
sArgSep = IIf(bConcat, ",", "&")
'Prompt user for absolute ref and separator options
If bOptions Then
sSeparator = " "
End If
'Create string of cell references
For Each c In rSelected.SpecialCells(xlCellTypeConstants)
sArgs = sArgs & c.Address(bRow, bCol) & sArgSep
If sSeparator <> "" Then
sArgs = sArgs & Chr(34) & sSeparator & Chr(34) & sArgSep
End If
Next
'Trim extra argument separator and separator characters
lTrim = IIf(sSeparator <> "", 4 + Len(sSeparator), 1)
sArgs = Left(sArgs, Len(sArgs) - lTrim)
'Create formula
'Warning - you cannot undo this input
'If undo is needed you could copy the formula string
'to the clipboard, then paste into the activecell using Ctrl+V
If bConcat Then
rOutput.Formula = "=CONCATENATE(" & sArgs & ")"
Else
rOutput.Formula = "=" & sArgs
End If
Selection.Copy
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.paste
Application.CutCopyMode = False
rSelected = ""
End If
End Sub
How to modify this code to work across, multiple columns, and variable number of rows, as shown in the image?
Considering the layout of the data is exactly as same as shown in the image, please give this a try...
Sub ConcatenateData()
Dim lr As Long, cnt As Long, n As Long, dlr As Long
Dim Rng As Range, cell As Range, ConcatRng As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim str1 As String, str2 As String, str3 As String, str4 As String
Application.ScreenUpdating = False
lr = ActiveSheet.UsedRange.Rows.Count
Columns("M:P").ClearContents
Columns(1).Insert
With Range("A1:A" & lr)
.Formula = "=IF(ISNUMBER(LEFT(B1,1)+0),1,NA())"
.SpecialCells(xlCellTypeFormulas, 16).ClearContents
.Value = .Value
End With
n = Range("A1:A" & lr).SpecialCells(xlCellTypeConstants, 1).Areas.Count
For Each Rng In Range("A1:A" & lr).SpecialCells(xlCellTypeConstants, 1).Areas
cnt = cnt + 1
If cnt <> n Then
Set ConcatRng = Range(Rng, Rng.End(xlDown).Offset(-1))
Set rng1 = ConcatRng.Offset(, 1).Resize(ConcatRng.Cells.Count, 4)
Set rng2 = ConcatRng.Offset(, 5).Resize(ConcatRng.Cells.Count, 2)
Set rng3 = ConcatRng.Offset(, 7).Resize(ConcatRng.Cells.Count, 2)
Set rng4 = ConcatRng.Offset(, 9).Resize(ConcatRng.Cells.Count, 3)
Else
Set ConcatRng = Range(Rng, Range("A" & lr))
Set rng1 = ConcatRng.Offset(, 1).Resize(ConcatRng.Cells.Count, 4)
Set rng2 = ConcatRng.Offset(, 5).Resize(ConcatRng.Cells.Count, 2)
Set rng3 = ConcatRng.Offset(, 7).Resize(ConcatRng.Cells.Count, 2)
Set rng4 = ConcatRng.Offset(, 9).Resize(ConcatRng.Cells.Count, 3)
End If
For Each cell In rng1.SpecialCells(xlCellTypeConstants, 2)
str1 = str1 & " " & cell.Value
Next cell
For Each cell In rng2.SpecialCells(xlCellTypeConstants, 1)
str2 = str2 & " " & cell.Value
Next cell
For Each cell In rng3.SpecialCells(xlCellTypeConstants, 2)
str3 = str3 & " " & cell.Value
Next cell
For Each cell In rng4.SpecialCells(xlCellTypeConstants, 2)
str4 = str4 & " " & cell.Value
Next cell
If Range("N1").Value = "" Then
dlr = 1
Else
dlr = Range("N" & Rows.Count).End(3)(2).Row
End If
Range("N" & dlr).Value = str1
Range("O" & dlr).Value = str2
Range("P" & dlr).Value = str3
Range("Q" & dlr).Value = str4
str1 = ""
str2 = ""
str3 = ""
str4 = ""
Next Rng
Columns(1).Delete
Columns("M:P").AutoFit
Application.ScreenUpdating = True
End Sub

Excel VBA - Loop & IF statement results not static and updating on each new run

I have racked my brain for to long on this simple problem that I cannot figure it out at this point.
The situation:
I have 2 columns, D and I. Column D is filled down to X# of rows.
I need to search for a string on each cell in D:X cell and based on the IF loop assign a value to I:X cell
The problem:
With each loop the value that is stored in the cells I-1 through I-X is updating with the most current value. So at the end of the third loop the values in I1-I3 are all Unknown. Any help is appreciated.
Old Code
Sub Country()
'Variables
Lastrow = Worksheets("SFDC").UsedRange.Rows.Count
lastrow2 = Worksheets("SFDC").UsedRange.Rows.Count
'check the rows for values
If lastrow2 > 1 Then
lastrow2 = 0
Else
End If
'Code will run until the last value it reached
Do While lastrow2 <> Lastrow
Set Check = Range("D2:D" & Lastrow)
For Each Cell In Check
If InStr(Cell, "ANZI-") Then
Range("I2:I" & cellvalue).Value = "ANZI"
lastrow2 = lastrow2 + 1
ElseIf InStr(Cell, "US-") Then
Range("I2:I" & cellvalue).Value = "US"
lastrow2 = lastrow2 + 1
Else
Range("I2:I" & cellvalue).Value = "Unknown"
lastrow2 = lastrow2 + 1
End If
Next
Loop
End Sub
New Code, Now the values are changing but its only being assigned to the initial cell I:2. But if I add +1 to the cellvalue like the previous codethen it still overwrites the previous values.
Sub Country()
'Variables
lastrow = Worksheets("SFDC").UsedRange.Rows.Count
'Code will run until the last value it reached
Set Check = Range("D2:D" & lastrow)
cellvalue = 2
For Each Cell In Check
If InStr(Cell, "ANZI-") Then
Range("I2:I" & cellvalue).Value = "ANZI"
ElseIf InStr(Cell, "US-") Then
Range("I2:I" & cellvalue).Value = "US"
Else
Range("I2:I" & cellvalue).Value = "Unknown"
End If
cellvalue = cellvalue + 1
Next
End Sub
just remove the Do...Loop because the For...Next is already doing the job for you. And, besides, it is better to do lastrow2 < Lastrow + 1 instead of lastrow2 <> Lastrow
I'm so dumb.
Sub Country()
'Get # of rows on worksheet
lastrow = Worksheets("SFDC").UsedRange.Rows.Count
'Setting variable for the For Loop
Set Check = Range("D2:D" & lastrow)
'will be used as a counter for the cell the return will be placed
cellvalue = 2
'Code will run until through each cell until the last value it reached
For Each Cell In Check
'if the string is in the D cell then the value will be written to the I cell
If InStr(Cell, "ANZI-") Then
Cells(cellvalue, "I") = "ANZI"
ElseIf InStr(Cell, "US-") Then
Cells(cellvalue, "I") = "US"
Else
Cells(cellvalue, "I") = "Unknown"
End If
cellvalue = cellvalue + 1
Next
End Sub
Just noticed that you got your answer but since I have already worked on, this is for your reference.
Option Explicit
Sub Country()
Dim lastRow As Long
Dim Check As Range
Dim rowNum As Long
Dim cell
'Get # of rows on worksheet
lastRow = Worksheets("SFDC").UsedRange.Rows.Count
'Setting variable for the For Loop
Set Check = Range("D2:D" & lastRow)
'will be used as a counter for the cell the return will be placed
'Code will run until through each cell until the last value it reached
For Each cell In Check
rowNum = cell.Row()
'if the string is in the D cell then the value will be written to the I cell
If InStr(cell, "ANZI") Then
Range("I" & rowNum) = "ANZI"
ElseIf InStr(cell, "US") Then
Range("I" & rowNum) = "US"
Else
Range("I" & rowNum) = "Unknown"
End If
Next
End Sub

Searching keywords in title

Im using the below code for seacrhing a set of keywords in a cell which has title. While running the code im getting "Run Time error 13" Type mismatch on b = cell.Value line.
Application.ScreenUpdating = False
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Set col = Range("KW[KW1]")
Dim target, cell As Range
Sheets("Data").Select
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
Dim term, tag As String
For Each cell1 In col
a = cell1.Value
term = a
tag = a
For Each cell In target
b = cell.Value
' If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True
However its running perfectly if we have 1000 tiltes in a column, but i want to run this code for a massive range upto 50,000 to 200,000. Please help me.
Try this, you didn't declare target as a range, might be it.
BTW, when you compare string VBA is case sensitive, so try to use Lcase() if you only want to compare content!
Application.ScreenUpdating = False
Dim target As Range, cell As Range
Dim term As String, tag As String
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Sheets("Data").Select
Set col = Range("KW[KW1]")
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
For Each cell1 In col
a = Cstr(cell1.Value)
term = a
tag = a
For Each cell In target
b = Cstr(cell.Value)
'If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True