I have to replace comma in the last column of any row with blank.I have below in excel.
1 _1 "",
2 _2 "",
3 _3 "",
4 _4 "",
5 _5 "",
My code. but it is not working.
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim length As Long
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
length = Len(Range("C" & lRow)) - 1
Range("C" & lRow).Value = Replace(Range("C" & lRow), ",", "", length)
Range("B2:B" & lRow).ClearContents
End Sub
This should do the trick: It will remove the last character in the last row if it is a comma (this assumes that you want to replace in column C as your code indicates):
Private Sub CommandButton1_Click()
Dim lRow As Long
lRow = ActiveSheet.UsedRange.Rows.Count
If Right(Range("C" & lRow).Value, 1) = "," Then
Range("C" & lRow).Value = Left(Range("C" & lRow), Len(Range("C" & lRow)) - 1)
End If
Range("B2:B" & lRow).ClearContents
End Sub
You could also use the replace, but it is trickier that way.
Related
I have the following code that is sort of working now but I've hit another snag. For some reason it is copying from the same sheet multiple times and pasting to the new workbook. I think this is due to my NumRange + 100 perimeter I set because I couldnt get the LastRow variable to work.
Public Sub extractCol()
'Find FF&E Section, Add 3 rows and Identify relevant columns.
Dim rFind As Range, CRange As String, ERange As String, KRange As String, MRange As String
Dim ws As Worksheet
Dim NewBook As Workbook
Dim NumRange As Long
Dim LastRow As Long
Set NewBook = Workbooks.Add ' Open new Workbook
For Each ws In ThisWorkbook.Worksheets
With ws
Set rFind = .Range("A:A").Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
NumRange = rFind.Row + 3 ' Find FF&E line and add three
CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 Lines in Column C
ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 Lines in Column E
KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 Lines in Column K
MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 Lines in Column M
Set range1 = Union(.Range(CRange), .Range(ERange), .Range(KRange), .Range(MRange)) ' Combine individual column ranges in to one selection
range1.Copy ' Copy new combined range
NewBook.Sheets(1).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook
NewBook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Resize(range1.Rows.Count).Value = FindRoom(ws)
End If
End With
Next ws
End Sub
Function FindRoom(ws As Worksheet)
shtName = ws.Name
Dim arr() As String
arr = VBA.Split(shtName, " ")
xCount = UBound(arr)
If xCount < 1 Then
FindRoom = "Unknown"
Else
FindRoom = arr(xCount)
End If
End Function
So I tried fixing it by doing the following;
CRange = "C" & NumRange & ":" & "C" & LastRow
ERange = "E" & NumRange & ":" & "E" & LastRow
KRange = "K" & NumRange & ":" & "K" & LastRow
MRange = "M" & NumRange & ":" & "M" & LastRow
But this causes an error on the following line;
range1.Copy
Any help on where I'm going wrong would be appreciated.
Thanks!
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
As mentioned in the title, I need a VBA equivalent to the Excel Value function. My data set looks like this: Data set example
What I am looking for is VBA code equivalent to this: =Value(A2)+Value(B2). That would go in column C
The output must be the same as that function. For the given example, column C should end up looking like this: End product
More than that, it needs to only have the value in the cell after the macro is run, rather than displaying the value and still having that formula in it.
Here is what I have done so far:
For i = 1 To LastRow
strValue = Val(sht.Range("A" & i))
strValue1 = Val(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
I also tried variations on this, a couple of which are shown below:
For i = 1 To LastRow
strValue = Evaluate(sht.Range("A" & i))
strValue1 = Evaluate(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
For i = 1 To LastRow
strValue = sht.Range("A" & i)
strValue1 = sht.Range("B" & i)
strVal = Evaluate(strValue)
strVal1 = Evaluate(strValue1)
sht.Range("C" & i).Value = strVal + strVal1
Next i
I can't find anything that will work for me. The output in C for the example set ends up being just 9. Pretty sure it is taking the first number in A and adding it to the first number in B. So when the hour in B changes to 1 C displays 10.
I also tried simply:
For i=1 To LastRow
sht.Range("C" & i).Value = sht.Range("A" & i).Value + sht.Range("B" & i).Value
Next i
That just concatenated the text to the format 9/03/15 00:00:00
Any and all help appreciated. Bonus if you can point me in the right direction for changing the final C values from that number (ie. 42250.00017) to the custom date/time format 'yyyy-mm-dd hh:mm:ss'.
Edit: Here is my code up to the sticking point. Everything else works as I want it to, the only problem is with the last For loop.
Sub sbOrganizeData()
Dim i As Long
Dim k As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim sFound As String
Dim rng As Range
Dim sheet As Worksheet
Dim Sheet2 As Worksheet
Dim strFile As String
Dim strCSV As String
Dim strValue As Double
Dim strValue1 As Double
Dim strVal As Long
Dim strVal1 As Long
Application.DisplayAlerts = False
Sheets("all016").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Set sheet = Sheets.Add
Set Sheet2 = Sheets.Add
sheet.Name = "all016"
Sheet2.Name = "Sheet1"
strFile = ActiveWorkbook.Path
strCSV = "*.csv"
sFound = Dir(strFile & "\*.csv")
If sFound <> "" Then
Workbooks.Open Filename:=strFile & "\" & sFound
End If
Range("A1").CurrentRegion.Copy Destination:=Workbooks("solar.xlsm").Sheets("all016").Range("A1")
Workbooks(sFound).Close
Set sht = ThisWorkbook.Sheets("all016")
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
sht.Range("C1").EntireColumn.Insert
For i = 1 To LastRow
'Code that doesn't quite work here'
sht.Range("C" & i).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Next i
The issue is that the dates and times are strings so something like this will work:
For i = 2 To LastRow
strValue = Evaluate("VALUE(TRIM(" & sht.Range("A" & i).Address(1,1,,1) & "))")
strValue1 = Evaluate("VALUE(TRIM(" & sht.Range("B" & i).Address(1,1,,1) & "))")
sht.Range("C" & i).Value = strValue + strValue1
'the format
sht.Range("C" & i).NumberFormat = "mm/dd/yy hh:mm:ss"
Next i
You have to reference the .Value2 field of the range element as:
For i = 1 To LastRow
sht.Range("C" & i).Value2 = sht.Range("A" & i).Value2 + sht.Range("B" & i).Value2
Next i
The value is free of formatting and just in Excel's time/date code as you want your final result to be. Cheers,
My goal of my macro:
I have 2 sheets, sheet1 master report and sheet2 import Input.
In column A of both sheets I have several strings in one cell.
I would like to see if there is a match and if there is the match the row from sheet2 (from column B) will be copied and paste in the row corresponding in sheet1.
This part of my code is done.
But now it starts to be tricky: If there is new string in the same cell as the matching string so I would like to add them as well in the cell of the column A sheet1.
For instance:
Sheet1 Column A Cell34:
MDM-9086
Sheet2 Column A Cell1:
MDM-9086,MDM-12345
After the macro it would be like this:
Sheet1 Column A cell34:
MDM-9086,MDM-12345
If there is no match between column A of both sheets so I would like to copy the entire row of the sheet2 and past it in the last free row of the sheet1.
See my code:
Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim I As Integer
Dim m As Range
Dim Tb
LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
With Worksheets(2)
LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
For NxtRw = 2 To LastRw2
Tb = Split(.Range("A" & NxtRw), ",")
For I = 0 To UBound(Tb)
With Sheets(1).Range("A2:A" & LastRw1)
Set m = .Find(Trim(Tb(I)), LookAt:=xlPart)
If Not m Is Nothing Then
Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("B" & m.Row)
Set m = Nothing
End If
End With
Next I
Next NxtRw
End With
End Sub
Example:
Sheet 1, Column A (start row 2)
MDM-123,MDM-27827
MDM-1791728,MDM-124
MDM-125
MDM-126,MDM-28920
MDM-127,MDM-1008
""
Sheet 2, Column A (start row 2)
MDM-123,MDM-27272
MDM-124
MDM-125,MDM-1289
MDM-126
MDM-1008
MDM-127
MDM-172891
Result on Sheet 1, Column A (start row 2):
MDM-123,MDM-27827,MDM-27272
MDM-124,MDM-1791728
MDM-125,MDM-1289
MDM-126,MDM-28920
MDM-127,MDM-1008
MDM-1008
MDM-172891
For your # 2.
Option Explicit
Public Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
Dim additions1 As String, additions2 As String
LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row
notFound = True
For NxtRw = 2 To LastRw2
celVal = Worksheets(2).Range("A" & NxtRw).Value2
If Len(celVal) > 0 Then
tb = Split(celVal, ",")
For i = 0 To UBound(tb)
Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
If Not m Is Nothing And notFound Then
Set rng1 = Worksheets(2).Range("B" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("B" & m.Row & ":Q" & m.Row)
rng1.Copy rng2
With Worksheets(2).Range("A" & NxtRw)
additions1 = Replace(.Value2, "," & tb(i), vbNullString)
additions1 = Replace(additions1, tb(i) & ",", vbNullString)
additions1 = Replace(additions1, tb(i), vbNullString)
End With
With Worksheets(1).Range("A" & m.Row)
additions2 = Replace(.Value2, "," & tb(i), vbNullString)
additions2 = Replace(additions2, tb(i) & ",", vbNullString)
additions2 = Replace(additions2, tb(i), vbNullString)
If Len(additions2) > 0 Then
If Len(additions1) > 0 Then
.Value2 = tb(i) & "," & additions2 & "," & additions1
Else
.Value2 = tb(i) & "," & additions2
End If
Else
.Value2 = tb(i) & "," & additions1
End If
End With
Set m = Nothing
notFound = False
End If
Next
If notFound Then
Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
rng1.Copy rng2
LastRw1 = LastRw1 + 1
End If
notFound = True
End If
Next
End Sub
It should work as expected now
Test data and result:
Why don't you copy the whole row from sheet2 to sheet1 like
For NxtRw = 2 To LastRw2
...
Sheets(2).Range("A" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("A" & m.Row)
...
Next NxtRw
? (The rest of the loop should stay the same.)
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.