I've been looking to write a macro to check 3 columns to ensure the contents are a date value. The columns can contain empty cells.
The below returns a message box for each cell that is not a date, even the blanks.
Sub DateCheck()
With ActiveSheet
lastRow = .Range("AB" & Rows.Count).End(xlUp).Row
For RowCount = 2 To lastRow
POC = .Range("AB" & RowCount)
If Not IsDate(POC) Then
MsgBox ("Please enter valid date in Cell : AB" & RowCount & ". Example: dd/mm/yyyy")
End If
Next RowCount
End With
End Sub
Could anybody be so kind as to help to adjust this to look at 3 non-adjacent columns, ignore blank cells and only return one message per column in the event it finds non-date values?
Thanks as always
Chris
Code:
Sub DateCheck()
Dim s(2) As String
Dim i As Integer
Dim o As String
Dim lastRow As Long
Dim r As Long
'Enter columns here:
s(0) = "A"
s(1) = "B"
s(2) = "C"
For i = 0 To 2
With ActiveSheet
lastRow = .Range(s(i) & Rows.Count).End(xlUp).Row
For r = 2 To lastRow
POC = .Range(s(i) & r)
If Not IsDate(POC) Then
o = o & ", " & .Range(s(i) & r).Address
End If
Next r
MsgBox ("Please enter valid date in Cells : " & Right(o, Len(o) - 1) & ". Example: dd/mm/yyyy")
o = ""
End With
Next i
End Sub
I would change your loop to a For Each In ... Next and use .Union to construct a range of non-adjacent columns.
Sub MultiDateCheck()
Dim lr As Long, cl As Range, rng As Range, mssg As String
With ActiveSheet
lr = .Range("AB" & Rows.Count).End(xlUp).Row
Set rng = Union(.Range("AB2:AB" & lr), .Range("AM2:AM" & lr), .Range("AZ2:AZ" & lr))
For Each cl In rng
If Not IsDate(cl.Value) And Not IsEmpty(cl) Then _
mssg = mssg & cl.Address(0, 0) & Space(4)
Next cl
End With
If CBool(Len(mssg)) Then
MsgBox ("Please enter valid date(s) in Cell(s): " & Chr(10) & Chr(10) & _
mssg & Chr(10) & Chr(10) & _
"Example: dd/mm/yyyy")
Else
MsgBox "All dates completed!"
End If
Set rng = Nothing
End Sub
I've used a single lastrow from column AB to determined the scope of the cells to be examined but individual rows for each column could easily be compensated for.
Addendum: Code modified for a single message showing rogue non-date/non-blank cells (as below). The Chr(10) is simply a line feed character.
Related
Because of the high chances of the arrangement of columns being adjusted in my raw data, I want to store the column numbers in variables.
I think that my syntax Columns(Variable_name) is wrong, but can't figure what will work
I tried Columns("Variable_name") which didn't work too.
Set Cws = Worksheets.Add
Cws.Name = "Ready_For_Send"
Dim Region As Integer: Region = 1
Dim Sub_Region As Integer: Sub_Region = 2
Dim User_Status As Integer: User_Status = 5
Dim Count As Integer: Count = 15
With Cws
.Range(.Columns(Region) & "," & .Columns(Sub_Region) & "," & .Columns(User_Status) & "," & Columns(Count)).Delete
End With
You can use the following:
With Cws
.Range(Cells(1, Region).EntireColumn.Address & "," _
& Cells(1, Sub_Region).EntireColumn.Address & "," _
& Cells(1, User_Status).EntireColumn.Address & "," _
& Cells(1, Count).EntireColumn.Address).Delete
End With
You can use the Union to merge all your columns to one Range, and then delete it.
Try the code below:
Dim DelRng As Range
With Cws
' Set a new range from all the columns you want to delete
Set DelRng = Union(.Columns(Region), .Columns(Sub_Region), .Columns(User_Status), .Columns(Count))
DelRng.Delete
End With
May be something like this:
Option Explicit
Sub DeleteCols()
Dim wb As Workbook
Dim Csw As Worksheet
Dim Region As Long
Dim Sub_Region As Long
Dim User_Status As Long
Dim Count As Long
Dim Cws As Worksheet
Region = 1
Sub_Region = 2
User_Status = 5
Count = 15
Set wb = ThisWorkbook
Application.DisplayAlerts = False
On Error Resume Next
Set Cws = wb.Worksheets.Add
Cws.Name = "Ready_For_Send"
On Error GoTo 0
Application.DisplayAlerts = True
With Cws
.Range( _
ReturnName(Region) & ":" & ReturnName(Region) & "," & _
ReturnName(Sub_Region) & ":" & ReturnName(Sub_Region) & "," & _
ReturnName(User_Status) & ":" & ReturnName(User_Status) & "," & _
ReturnName(Count) & ":" & ReturnName(Count) _
).Delete Shift:=xlToLeft
End With
End Sub
Function ReturnName(ByVal num As Integer) As String
ReturnName = Split(Cells(, num).Address, "$")(1)
End Function
Some structure and Function from here: Delete multiple columns
I have included error handling in case sheet already exists. Also full declarations. I have also put declarations and assignments on different lines for ease of reading.
I want to create a macro that check all the cells of a column and if the first two characters of a cell is "BB" then i want the macro to extract three characters from the cell and paste it to the next column but a the corresponding row.
But my formula after the if clause is not working.
this is what i have done since:
Sub test()
Dim lmid As String
Dim srange, SelData, ExtBbFor As String
Dim lastrow As Long
Dim i, icount As Integer
lastrow = ActiveSheet.Range("B30000").End(xlUp).Row
srange = "G1:G" & lastrow
SelData = "A1:G" & lastrow
Range(srange).Formula = "=mid(E1,1,3)"
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "bb") <> 0 Then
Range("G" & i).Formula = "=mid("E & i", 4, 3)"
End If
Next i
End Sub
thanks in advance
Try with below. It will work
Range("G" & i).Value = Mid(Range("E" & i), 4, 3)
If the cell is not limited to 7 then you need as below
Range("G" & i).Value = "=Mid(E" & i & ", 3, " & Len(E & "& i & ") & ")"
It will extract from the 3rd character up to the last character in a cell.
Your syntax is wrong where you're trying to concatenate strings, I think you mean to use:
Range("G" & i).Formula = "=MID(E" & i & ",4,3)"
Based on your code I think this will do the exact same thing without having to loop or declare any variables:
Sub test()
With Range("G1:G" & Cells(Rows.Count, 2).End(xlUp).Row)
.FormulaR1C1 = "=IF(UPPER(LEFT(RC[-2],2))=""BB"",MID(RC[-2],4,3),"""")"
.Value = .Value
End With
End Sub
Goal: create a separate Word page (can all be in the same Word doc) for each row in my Excel document.
Row 1 contains questions and Rows 2-n contain people's responses. Here's what I would like as an output:
Page 1 of Word Doc:
A1 Question
A2 Answer
B1 Question
B2 Answer
etc.
Page 2 of Word Doc:
A1 Question
A3 Answer
B1 Question
B3 Answer
etc.
If it's possible to have the questions (all of Row 1) bolded in the Word output, that would be fantastic!
Here's the code I'm working with now.
Sub WordDoc()
Dim TextEnter As String
Dim RowNum As Integer
Dim wordApp As Object
Set wordApp = CreateObject("word.application") 'Takes the object wordApp and assigns it as a Microsoft Word application
wordApp.Visible = True 'Word application is visible
'Adds a new document to the application
wordApp.Documents.Add _
Template:="", _
NewTemplate:=False
RowNum = 1
'Loop continues until a blank line is read; can be edited as necessary
Do While Range("A" & RowNum).Text <> ""
TextEnter = Range("A" & RowNum).Text & " " & Range("B" & RowNum).Text & " " & Range("C" & RowNum).Text & " " & Range("D" & RowNum).Text & " " & Range("E" & RowNum).Text & " " & Range("F" & RowNum).Text & " " & Range("G" & RowNum).Text & " " & Range("H" & RowNum).Text
'Puts text of row into a string adjust to the number of columns by adding more range
wordApp.Selection.TypeParagraph 'Moves to the next line in word doc
wordApp.Selection.TypeText Text:=TextEnter 'Enters Text to document
RowNum = RowNum + 1 'Increments to the next row
Loop
End Sub
Problems with current code:
I need Row 1 to be repeated for each response. The code, as it is now, just bundles the row's information together into a paragraph.
I would like the code to be dynamic and loop through however many columns there are, without having to define each column.
I would like each response to be on a separate page in the Word doc.
Noted what my code does inline.
Sub WordDoc()
Dim TextEnter As String
Dim RowNum As Integer
Dim wordApp As Object
Dim LastRow, LastCol, CurRow, CurCol As Long
Set wordApp = CreateObject("word.application") 'Takes the object wordApp and assigns it as a Microsoft Word application
wordApp.Visible = True 'Word application is visible
'Adds a new document to the application
wordApp.Documents.Add _
Template:="", _
NewTemplate:=False
LastRow = Range("A" & Rows.Count).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'For... Next Loop through all rows
For CurRow = 2 To LastRow
TextEnter = ""
'For... Next Loop to combine all columns (header and answer) for given row into string
For CurCol = 1 To LastCol
TextEnter = TextEnter & Cells(1, CurCol).Value & vbCrLf & Cells(CurRow, CurCol).Value & vbCrLf
Next CurCol
wordApp.Selection.TypeParagraph 'Moves to the next line in word doc
wordApp.Selection.TypeText Text:=TextEnter 'Enters Text to document
wordApp.Selection.InsertBreak Type:=7 ' wdPageBreak
Next CurRow
End Sub
I'm still quite new to VBA and struggling with the following code!
What I am trying to do is have the search function look through all cells within column 1 and find the criteria of Cell 1 matches PickerName2.Text and offset cell 5 is <>0 and then offset cell 6 = Blank
The problem I have is there a duplicates all the way down column 1 and as soon as it finds the matching name to PickerName2 Then it checks the offset cells 5 & 6 and as these don't match the criteria it gives the message they aren't currently picking.
This is even though further down the sheet there is a record that matches the criteria. I want it to look through all records until it find the criteria or if it has checked all populated cells in column A and nothing matches then it will give the message that they aren't currently picking.
I do hope someone can help :-)
Al
Private Sub CommandButton3_Click()
Dim iRow As Long
Dim ws As Worksheet
Dim strSearch As String
Dim aCell As Range
Dim rng As Range, i As Long
'~~> Set the sheet where you want to search the IMEI
Set ws = Sheets("PickData")
With ws
'~~> Get the value which you want to search
strSearch = PickerName2.Text
'~~> Column A is Column 1 so Column B is 2. This is where we are searching
'~~> xlWhole is used in the code below so that we find a complete match
'~~> xlPart is supposed to be used when you are finding a partial match.
Set aCell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> get the row of the cell where we found the match and add data to
If Not aCell Is Nothing And aCell.Offset(0, 5).Value <> "" And aCell.Offset(0, 6).Value = "" Then
MsgBox " " & PickerName2.Text & " is currently picking - " & aCell.Offset(0, 1) & " " & aCell.Offset(0, 2) _
& " " & aCell.Offset(0, 3) _
& " "
UserForm1.Hide
Else
MsgBox " " & PickerName2.Text & " has no outstanding PIK!", vbExclamation
PickerName2.Value = ""
Exit Sub
End If
End With
PickNo2.Value = ""
PickerName2.Value = ""
UserForm1.Hide
End Sub
I have done some searching online and tried something similar to the following code but keep getting a object required error but cannot see where I am going wrong?
Dim rng As Range
Dim i As Integer
Dim finalrow As Integer
finalrow = Sheets("PickData").Range("A10000").End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 1).Value = UserForm1.PickerName2.Text And (Cell.Offset(i, 5) <> "") And (Cell.Offset(i, 6) = "") Then
MsgBox " " & PickerName2.Text & " is currently picking - " & Cell.Offset(i, 1) & " " & Cell.Offset(i, 2) _
& " " & Cell.Offset(i, 3) _
& " "
End If
Next i
Your first code attempt using the Range.Find method is a good start.
Now extend this approach by using the Range.FindNext method.
This link should help you.
In your second block of code:
The references to Cell.Offset... should probably be something like Cells(i,1).Offset(0,5) and Cells(i,1).Offset(0,1) and Cells(i,1).Offset(0,3) respectively.
Also the second reference to PickerName2 should be qualified with UserForm1, as in UserForm1.PickerName2
My Excel sheet has multiple used ranges. I want to copy each range value and concatenate them. What I did is
Set tempRange = Union(SrcWkb.Worksheets("mysheet").Range("F1:H1"), SrcWkb.Worksheets("mysheet").Range("I1:J1"), SrcWkb.Worksheets("NWP").Range("K1:L1"))
For Each eachRange In tempRange
tempString = tempString & eachRange & "/"
MsgBox tempString
Next eachRange
I want to copy the value in merged cells F1:H1 and concatenate a "/" and value from I1:J1 (also merged) and K1 to L1. However, Excel throws "subscript out of range" error. How could I achieve this?
It is not quite clear from your original post what output you need. Here is one option which may help you get started:
Sub ConcatRanges()
Dim rangeOne As Range, rangeTwo As Range, rangeAll As Range, cl As Range, str As String
Set rangeOne = Worksheets("mysheet").Range("I27:K27")
Set rangeTwo = Worksheets("mysheet").Range("L27:N27")
Set rangeAll = Union(rangeOne, rangeTwo)
For Each cl In rangeAll
str = str & cl & " / "
Next cl
Debug.Print str //Output: 1 / 2 / 3 / 4 / 5 / 6 /
End Sub
Updated Post
Dealing with merged ranges can be tricky. For example, the merged range F1:H1 has value 36M. To access the value you have to refer to the first cell in the merged range. Example:
Sub MergedRangeDemo()
Dim rng As Range, cl As Range
Set rng = ActiveSheet.Range("F1:H1")
For Each cl In rng
Debug.Print cl.Value, cl.Address
Next cl
//Output: 36M $F$1 <-- Only first cell contains the value
// $G$1
// $H$1
End Sub
Given this you can concatenate the values by using the rowindex (1) of the range:
Sub ConcatRangesUpdated()
Dim rangeOne As Range, rangeTwo As Range, rangeThree As Range, str As String
Set rangeOne = ActiveSheet.Range("F1:H1")
Set rangeTwo = ActiveSheet.Range("I1:J1")
Set rangeThree = ActiveSheet.Range("K1:L1")
str = rangeOne(1) & " / " & rangeTwo(1) & " / " & rangeThree(1)
Debug.Print str 'Output: 36M / 40M / 36M
End Sub
It appears that you want to concatenate I27 and L27 with a forward slash between and put the results on a different worksheet. This example does just that: concatenates I27 & L27, J27 & M27, K27 & N27 and puts the results in cells A27:C27 on the destination sheet. Note that the formula uses R1C1 notation with relative column positions; adjust as necessary.
Sub ConcatCells()
Dim sSource As String
sSource = "'" & SrcWkb.Worksheets("mysheet").Name & "'!"
DstWks1.Range("A27:C27").FormulaR1C1 = "=" & sSource & "RC[8] & " _
& Chr$(34) & "/" & Chr$(34) & " & " & sSource & "RC[11]"
End Sub