I'm trying to combine the data from a date column and a time column. I'm using the following code:
Sub Concat()
Dim lRow As Long
lRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
Cells(i, 10) = Cells(i, 6) & " " & Cells(i, 7)
Cells(i, 11) = Cells(i, 8) & " " & Cells(i, 9)
Next I
Cells(1, 9).Copy
Cells(1, 10).PasteSpecial Paste:=xlPasteFormats
Cells(1, 11).PasteSpecial Paste:=xlPasteFormats
Cells(1, 10) = "Request Time"
Cells(1, 11) = "Validation Time"
End Sub
the result I get is this:
Input data:
Creation_Date Creation Time Change Date Change Time Request Time Validation Time
01/23/2017 8:20:10 01/23/2017 8:20:10 1/23/2017 0.347337962962963 1/23/2017 0.347337962962963
The time turns into a decimal that cannot be converted back to a time. before concatenate function, the date column is formatted for date and the time column is formatted to time.
Please help.
The underlying data type of a date/time format is most likely a 64-bit floating. I would suggest converting to String the values before concatenating and after that, applying the datetime format.
You could change your loop as follows:
For i = 2 To lRow
Cells(i, 10) = Cells(i, 6) + Cells(i, 7)
Cells(i, 11) = Cells(i, 8) + Cells(i, 9)
Cells(i, 10).NumberFormat = "m/dd/yyyy h:mm:ss"
Cells(i, 11).NumberFormat = "m/dd/yyyy h:mm:ss"
Next I
Of course, the formatting of columns J & K could be done in Excel, rather than in code, if that was easier for you.
The important thing is to just add the date and the time, not to try and create a string with the values joined together. (The time 8:20:10 is just a number which is equal to 8/24 + 20/24/60 + 10/24/60/60, i.e. 0.347337962962963, which is why the resultant string was being created as 1/23/2017 0.347337962962963 and, once it was a string then Excel is going to have a hard time treating it as anything else.)
Related
I have a small script which arranges a budget into a monthly format another software accepts. The script works mostly fine, except that some numbers aren't divisible by 12. I'm having trouble correcting that.
The table originally looks something like:
..and when the script is run, the table turns to:
..for a total sum of 12 999.60 - not the original 13 000.00. The difference may look a bit trivial, but the numbers are in tens of thousands so they do unfortunately matter a lot.
I did think I could account for the rounding error though by taking the total rounded number and subtracting the original number in the last entry, which may sound like a clunky solution but it's OK, but this gave the following result:
..which is a total of 13 003.60. I could be going about this all wrong and the solution may be stupid simple, for which I ask you to forgive my incompetence, but this is the code with the attempted correction:
'For each budget post..'
For Each row In rng.Rows
Dim i As Long
'Decimal count var'
Dim countDec As Long
countDec = 0
'Repeat twelve times'
For i = 1 To 12
'Test if row is empty'
If Len(Range("A" & x).Value) > 0 Then
'Add the current periods number to the variable..'
countDec = countDec + Round(Range("D" & x).Value / 12, 1)
'New values to cells'
Cells(j, 6).Value = Range("A" & x).Value 'Account'
Cells(j, 7).Value = i 'Period value +1'
Cells(j, 8).Value = Range("C" & x).Value 'Cst'
'Correct decimal on 12th iteration'
If i = 12 Then
countDec = countDec - Range("D" & x).Value 'Count the difference between the total periods and the original value'
Cells(j, 9).Value = Round(Range("D" & x).Value / 12, 1) + countDec '1/12th plus sum of decimal difference'
ElseIf i <> 12 Then
Cells(j, 9).Value = Round(Range("D" & x).Value / 12, 1) 'If not last iteration, just print rounded period value'
End If
j = j + 1
End If
Next i
x = x + 1
Next row
Try this If i = 12 clause:
If i = 12 Then
Cells(j, 9).Value = Range("D" & x).Value - Round(Range("D" & x).Value / 12, 1) * 11
I have a Userform that populates Textboxes with dates from a worksheet. The idea is to be able to edit the dates and save them back to the worksheet. The problem is the dates show up in American format, not European. I understand that I need to use code to force the date to show as European. So I have tried using this code
Dim LValue As String
LValue = Format(Date, "dd/mm/YYYY")
I then have a function to populate the form, where I want the correct date format to show
Sub PopulateForm()
Me.Location.Value = rngFound(1, 0).Value
Me.ID.Value = rngFound(1, 1).Value
Me.FirstName.Value = rngFound(1, 2).Value
Me.LastName.Value = rngFound(1, 3).Value
Me.Grade = rngFound(1, 4).Value
Me.ARLFam = rngFound(1, 8).Value
Me.ARLEvac = rngFound(1, 11).Value
Me.HRDFam = rngFound(1, 16).Value
Me.HRDEvac = rngFound(1, 19).Value
Me.CRDFam = rngFound(1, 24).Value
Me.CRDEvac = rngFound(1, 27).Value
Me.RSQFam = rngFound(1, 32).Value
Me.RSQEvac = rngFound(1, 35).Value
Me.COVFam = rngFound(1, 40).Value
Me.COVEvac = rngFound(1, 43).Value
Me.LSQFam = rngFound(1, 48).Value
Me.LSQEvac = rngFound(1, 51).Value
Me.HPCFam = rngFound(1, 56).Value
Me.HPCTrackFam = rngFound(1, 63).Value
Me.HPCEvac = rngFound(1, 59).Value
Me.KNBFam = rngFound(1, 67).Value
Me.KNBEvac = rngFound(1, 70).Value
End Sub
I haven't figured out where to place LValue in the sub routine for it to change the dates to the correct format. Am I on the right track? Or am I barking up the wrong tree?
Next, when I have changed the dates and save the changes to the worksheet, I encounter a new problem. The cells the dates go into are set up as dates, and other cells have formulas working off the information provided by the date cells. When I save the dates from the Userform, they show up in the correct cells, but all the other cells reading from the date cell now have the #Value error showing. This is the code used to save the new dates to the worksheet.
Private Sub EnterButton_Click()
Dim LR As Long
Dim replace As Long
Dim response As Long
Dim LValue As String
LValue = Format(Date, "dd/mm/YYYY")
If Me.ID.Value = "" Then
MsgBox "You have not entered an ID."
Me.ID.SetFocus
Exit Sub
End If
FindRecord (Val(Me.ID))
If Not rngFound Is Nothing Then
replace = MsgBox("This record already exists in this Database." & vbNewLine _
& "Replace?", vbYesNo)
If replace = vbYes Then
LR = rngFound.Row
Else
ClearForm
Me.ID.SetFocus
Exit Sub
End If
Else
LR = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
With ws
.Cells(LR, 1).Value = Me.Location
.Cells(LR, 2).Value = Val(Me.ID)
.Cells(LR, 3).Value = Me.FirstName
.Cells(LR, 4).Value = Me.LastName
.Cells(LR, 5).Value = Me.Grade
.Cells(LR, 9).Value = Me.ARLFam
.Cells(LR, 12).Value = Me.ARLEvac
.Cells(LR, 17).Value = Me.HRDFam
.Cells(LR, 20).Value = Me.HRDEvac
.Cells(LR, 25).Value = Me.CRDFam
.Cells(LR, 28).Value = Me.CRDEvac
.Cells(LR, 33).Value = Me.RSQFam
.Cells(LR, 36).Value = Me.RSQEvac
.Cells(LR, 41).Value = Me.COVFam
.Cells(LR, 44).Value = Me.COVEvac
.Cells(LR, 49).Value = Me.LSQFam
.Cells(LR, 52).Value = Me.LSQEvac
.Cells(LR, 57).Value = Me.HPCFam
.Cells(LR, 64).Value = Me.HPCTrackFam
.Cells(LR, 60).Value = Me.HPCEvac
.Cells(LR, 68).Value = Me.KNBFam
.Cells(LR, 71).Value = Me.KNBEvac
End With
If replace = vbYes Then
MsgBox "The existing record on " & ws.Name & " row# " & rngFound.Row & " was overwitten"
Else
MsgBox "The record was written to " & ws.Name & " row# " & LR
End If
response = MsgBox("Do you want to enter another record?", _
vbYesNo)
If response = vbYes Then
ClearForm
Me.ID.SetFocus
Else
Unload Me
End If
End Sub
Is it because the date has been saved as text instead of a date? If so, how do I get it to save as a European date?
The following assumes that you have real dates in Excel (you can prove this for example by formatting a cell containing a date as General: It should display a number).
Background: dates are stored internally as numbers, the integer part
gives the Date-part, counting the number of days starting from 1.
January 1900. The fraction part is representing the time, 1/3 would be
8am (a third of the day)
A textbox in VBA contains always a String. When you want to write a date into the textbox and use code like tbStartDate = ActiveSheet.Cells("B2") and B2 contains a date, you are asking VBA to convert the date into a string. VBA will do so, but it has it's own rules for that and so you end up with a string that looks like an US date. Basically, you should always avoid that VBA does an automatic conversion for you. Instead, use a function for that: Format it the right function to convert a Date or a number into a string, you use it already correctly in the first 2 statements. To write the date into the textbox, you now write
tbStartDate = Format(ActiveSheet.Cells("B2"), "dd/mm/YYYY")
Now comes the tricky part: The user may change the date and you want to write it back to the cell. Again, you shouldn't let Excel do the conversion implicitly. The problem is that with a normal text box you cannot prevent that the user enters rubbish stuff (you might read Formatting MM/DD/YYYY dates in textbox in VBA).
But let's assume your user enters the date in the "correct" form: How do you convert a string into a date?
You often see the answer to use CDate that converts a string into a date, respecting the locale setting of the system. Fine, as long as all users have the same settings. But if you might have a user coming with a Laptop freshly imported from the US or that comes from any other part of the world, you have the same problem again: VBA will convert the date with wrong assumptions (eg changing the day- and month part).
Therefore I usually use a small custom function that splits the string and use the parts as parameters into another VBA function DateSerial. It will return 0 (=1.1.1900) if the input is complete nonsense, but doesn't check all invalid possibilities. A 13 as input is happily accepted (DateSerial, btw, accepts this also).
Function StrToDate(s As String) As Date
' Assumes input as dd/mm/yyyy or dd.mm.yyyy
Dim dateParts() As String
dateParts = Split(Replace(s, ".", "/"), "/") ' Will work with "." and "/"
If UBound(dateParts) <> 2 Then Exit Function
Dim yyyy As Long, mm As Long, dd As Long
dd = Val(dateParts(0))
mm = Val(dateParts(1))
yyyy = Val(dateParts(2))
If dd = 0 Or mm = 0 Or yyyy = 0 Then Exit Function
StrToDate = DateSerial(yyyy, mm, dd)
End Function
Now, writing the input back to the cell could be like
dim d as Date
d = StrToDate(tbStartdate)
if d > 0 then ActiveSheet.cells(B2) = d
you surely can change the current forat into an european one and here is some examples of how you can uses it :
Sub dates_et_heures()
'Now renvoie la date et l'heure en cours (07.02.2018 09:09:02)
date_test = Now()
'Renvoie : 07.02.18
Range("A1") = Format(date_test, "dd.mm.yy")
'Renvoie : mardi 7 février 2018
Range("A2") = Format(date_test, "dddd d mmmm yyyy")
'Renvoie : Mardi 7 Février 2018
Range("A3") = WorksheetFunction.Proper(Format(date_test, "dddd d mmmm yyyy"))
'Renvoie : mar. 07
Range("A4") = Format(date_test, "ddd dd")
'Renvoie : MAR 07
Range("A5") = "'" & Replace(UCase(Format(date_test, "ddd dd")), ".", "")
'Renvoie : FÉVRIER 2018
Range("A6") = UCase(Format(date_test, "mmmm yyyy"))
'Renvoie : 07.02.2018 09:09
Range("A7") = Format(date_test, "dd.mm.yyyy hh:mm")
'Renvoie : Le 7 février à 9h09'02''
Range("A8") = Format(date_test, "Le d mmmm à h\hmm'ss''")
'Renvoie : 9H09
Range("A9") = Format(date_test, "h\Hmm")
End Sub
I don't have the answer for the second part but i hope this could help too
I am trying to create a pricing sheet which will import a CSV BOM from Creo into a new worksheet, I have that part sorted. The problem is the next part i want...
We have different values in column 'G' which are for the different materials e.g: 'MS', 'SS', 'ANGLE', 'PURCHASED'
The issue I have is creating a 'total cost' in column 'J' which is based on the material in 'G'. If the value is "MS" then the value in Column 'J' should be quantity x unit mass x material cost.
'Quantity' is the value in column C, 'unit mass' is the value in column E and 'material cost' is always cell H5 in worksheet named 'MASTER' (this is where the total cost column J should be driven from)
Sub subMultiply()
For Each Cel In Range("G2:D" & Cells(Rows.Count, "G").End(xlUp).Row)
If Cel.Value = "MS" Then
Cel.Offset(0, 3).Value = Cel.Offset(0, -2).Value * ThisWorkbook.Sheets(MASTER).Range(H5).Value * Cel.Offset(0, -4).Value
ElseIf Cel.Value = "PURCHASED" Then
Cel.Offset(0, 3).Value = Cel.Offset(0, -3).Value * ThisWorkbook.Sheets(MASTER).Range(H6).Value * Cel.Offset(0, -4).Value
End If
Next
End Sub
You should try with the select case function
SOmething like :
Select Case Cells(i, 7)
Case Is = "MS"
Cells(i, 10) = 3
Case Is = "SS"
Cells(i, 10) = 5
Case Is = "ANGLE"
Cells(i, 10) = 8
Case Is = "PURCHASED"
Cells(i, 10) = 11
End Select
Instead of the numbers (3,5,8 and11) I used for my test, you can use whatever you want.
You can use the sheets function to select sheets :
Sheets("MASTER").Cells(5,8) is H5 on the Master Sheets.
Ex : Sheets("Sheet2").Cells(1, 1).Select
'''
Firstrow = .UsedRange.Cells(1).Row
lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For lRow = lastrow To Firstrow Step -1
Set ws2 = ThisWorkbook.Sheets("MASTER")
With .Cells(lRow, "G")
If Not IsError(.Value) Then
If .Value Like ("*MS*") Then Cells(lRow, "D").Value = Cells(lRow, "E").Value * ws2.Range("H5").Value
'''
I was able to add another If statement for each type of material
In an excel Sheet, I have two colomns A & B (filled with text). I need to find for every same value in A, the part of the text in B that is similar.
Example below:
the pictures named product_1000.jpg have in common "thecat_" which needs to be given in the third colomn.
How to find the colomn C automatically? (Excel formula or VBA).
Note: My Table has around 40k lines.
I found my own answer thanks to the linked question of danieltakeshi's comment
Sub SerieNames()
Dim LastRow As Long
LastRow = sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For a = 2 To LastRow
If Cells(a, 1).Value = Cells(a - 1, 1).Value Then
For i = 1 To Len(Cells(a - 1, 3))
If (Left(Cells(a, 2), i) <> Left(Cells(a - 1, 3), i)) Then
Cells(a, 3).Value = Left(Cells(a - 1, 3), i - 1)
Exit For
End If
Next i
If Cells(a, 3).Value = "" Then
Cells(a, 3).Value = Cells(a - 1, 3).Value
End If
Else: Cells(a, 3).Value = Cells(a, 2).Value
End If
Next a
End Sub
This Code is putting in the colomn C the longest common string starting from the left side.
After that I only needed to find the last result of every serie in the colomn C to find my answer. This can be done with formula just by counting the shortest string result of C for every serie.
Note: The colomn A has to be sorted beforehand, otherwise the code will not work.
I have some excel data that comes from a lab in a strange format and am trying to figure out how to put all of the patient data on the same line. An example is below, with a single entry highlighted in red so you can see that the whole thing spans 3 lines:
I think a macro would work well for something like this but recording macros is the extent of my knowledge. I do not really know how to write VBA. The goal is to get all patient information on the same row so that they can be filtered (example below):
What I have done to figure this out on my own: I began recording a macro and manually changing things (for the recording) when I realized that the references might change depending on the heading of the worksheet, which changes. I could do a relative reference macro but then pointing the cursor to the right spot for each patient over and over is almost as much work as doing it by hand. It seemed like there should be a way to say "everything contained in three lines is one 'entry', so put on one line, starting here and ending there" or something?
How's this:
Sub text()
Dim lastRow As Integer, ageCol As Integer, addressCol As Integer, i As Integer, endRow As Integer
Dim startRow As Integer, phoneCol As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
ageCol = Rows(1).Find(what:="DOB_Age").Column
addressCol = Rows(1).Find(what:="Address").Column
phoneCol = Rows(1).Find(what:="Phone").Column
'Starting off, go to first name in the list.
startRow = Cells(1, 1).End(xlDown).Row
endRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For i = startRow To endRow
Cells(i, 1).Select
If Cells(i, 1).Value <> "" Then
Cells(i, ageCol).Value = Cells(i, ageCol).Value & " " & Cells(i, ageCol).Offset(1, 0).Value
Cells(i, addressCol).Value = Cells(i, addressCol).Offset(-1, 0).Value & ", " & Cells(i, addressCol).Value & ", " & Cells(i, addressCol).Offset(1, 0).Value
Cells(i, phoneCol).Value = Cells(i, phoneCol).Offset(1, 0).Value
' Now, let's clear the data we copied over.
Cells(i, ageCol).Offset(1, 0).Value = ""
Cells(i, addressCol).Offset(-1, 0).Value = ""
Cells(i, addressCol).Offset(1, 0).Value = ""
Cells(i, phoneCol).Offset(1, 0).Value = ""
End If
Next i
'Now, let's delete all the empty rows
For i = 1 To endRow
If i > endRow Then Exit For
If IsEmpty(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
i = i - 1
endRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
End If
Next i
End Sub
Note: This assumes that your data will always look like your question - the row with a name on it has ONE row above and ONE row below that need to be moved to the name's row. Please let me know what works/what doesn't work and needs tweaking. Good luck!
Multiple Formula (Non-VBA) Solution:
This option would be to get the values to appear in another sheet using formulas and autofilling down.
Note: this option assumes that all your data is as shown in the images, currently I do not account for any exceptions (which can be added)
Here are the formulas (using "Sheet1" as the reference sheet, change that to whatever your sheet name is):
(Horizontal view, ..have fun scrolling..)
A B C D E F
----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
1| Id Patient_Name Sex DOB_Age Address Phone
2| =INDIRECT("Sheet1!A"&(ROW()-1)*3) =INDIRECT("Sheet1!B"&(ROW()-1)*3) =INDIRECT("Sheet1!C"&(ROW()-1)*3) =TEXT(INDIRECT("Sheet1!D"&(ROW()-1)*3),"m/d/yyy")&", "&INDIRECT("Sheet1!D"&(ROW()-1)*3+1) =INDIRECT("Sheet1!E"&(ROW()-1)*3-1)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3+1) =INDIRECT("Sheet1!F"&(ROW()-1)*3+1)
3| ..Autofill down..
(Vertical view)
Id
=INDIRECT("Sheet1!A"&(ROW()-1)*3)
Patient_Name
=INDIRECT("Sheet1!B"&(ROW()-1)*3)
Sex
=INDIRECT("Sheet1!C"&(ROW()-1)*3)
DOB_Age
=TEXT(INDIRECT("Sheet1!D"&(ROW()-1)*3),"m/d/yyy")&", "&INDIRECT("Sheet1!D"&(ROW()-1)*3+1)
Address
=INDIRECT("Sheet1!E"&(ROW()-1)*3-1)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3+1)
Phone
=INDIRECT("Sheet1!F"&(ROW()-1)*3+1)
Now since these are formulas and not vba, the data will automatically change if the source changes. So if you want to only keep the values you can copy -> paste special -> values on a new sheet to keep only the values
Sub Parse_Data()
Dim rngTarget As Range, x As Long
Set rngTarget = Worksheets("Target").Range("A2")
For x = 2 To Range("E1").Offset(Rows.Count - 1).End(xlUp).Row
Select Case x Mod 3
Case 2
rngTarget.Offset(, 5).Value = Range("A1").Offset(x - 1, 4).Value
Case 0
rngTarget.Offset(, 0).Value = Range("A1").Offset(x - 1, 0).Value
rngTarget.Offset(, 1).Value = Range("A1").Offset(x - 1, 1).Value
rngTarget.Offset(, 2).Value = Range("A1").Offset(x - 1, 2).Value
rngTarget.Offset(, 3).Value = Range("A1").Offset(x - 1, 3).Value
rngTarget.Offset(, 6).Value = Range("A1").Offset(x - 1, 4).Value
Case 1
rngTarget.Offset(, 4).Value = Range("A1").Offset(x - 1, 3).Value
rngTarget.Offset(, 7).Value = Range("A1").Offset(x - 1, 4).Value
rngTarget.Offset(, 8).Value = Range("A1").Offset(x - 1, 5).Value
Set rngTarget = rngTarget.Offset(1)
End Select
Next x
End Sub