Conell8383
Board Regular
- Joined
- Jul 26, 2016
- Messages
- 66
Joining two pieces of VBA Code. Formatting a column to Date Format
Hi all. I hope you are well. I have two pieces of code that work and function correctly. The first piece of code essentially executes a Vlookup of three columns using a unique identifier from one sheet and puts them into another.
The issue I am facing is that when one of the columns (Column M from 2nd picture) comes from one sheet to another it is not in a date format. (Column AB in 1st Picture) I would like it to be in date format. I have written code to change the format I just need to insert it into the existing code. Any help would be greatly appreciated. I have added pictures for easier understanding.
Picture 1
Picture 2
1st piece of code
2nd piece of code
Thanks for any assistance
Hi all. I hope you are well. I have two pieces of code that work and function correctly. The first piece of code essentially executes a Vlookup of three columns using a unique identifier from one sheet and puts them into another.
The issue I am facing is that when one of the columns (Column M from 2nd picture) comes from one sheet to another it is not in a date format. (Column AB in 1st Picture) I would like it to be in date format. I have written code to change the format I just need to insert it into the existing code. Any help would be greatly appreciated. I have added pictures for easier understanding.
Picture 1
Picture 2
1st piece of code
Code:
Sub Add_consent()
'Definition of used variables
Dim Directory As String 'Directory for inputs and outputs
Dim Consent_folder As String 'Directory for inputs and outputs
Dim inputFile As String 'Input file name
Dim currentInput As String 'Input file name
Const DELIMITER As String = "|" 'Values delimiter
Dim OutputFile As String 'Output file name
Dim lngCount As Long 'selected files count
Dim wbkOutput As Workbook 'output workbook
Dim wbkTemp As Workbook 'temporary workbook
Dim myWkBook As Workbook 'Input Workbook
Dim Consent As Workbook 'Consent file
Dim Consent_name 'new opened file
Dim myWkSheet As Worksheet 'Input Worksheet
Dim sheetNum As Long 'Variable for sheet number
Dim sheetNames() As String 'output worksheet sheet names
Dim sheetInterfaceName 'Sheet name representing DID interface
Dim Active As Worksheet 'Active worksheet
Dim intLastRow As Long 'Last row element
Dim Error_Codes As Worksheet ' Sheet containing error codes
Dim myRecord As Range 'Record for output
Dim myField As Range 'Cell value for output
Dim nFileNum As Long 'Variable for file number
Dim sOut As String 'Text to be written into file
Dim invalidDelete As String 'Case of invalid delete attempt
Dim sheetIndex As Long ' Current sheet index
Dim Selected As Long '
Dim rwCount As Long 'Number of current sheet rows containing data in tracking file
Dim colCount As Integer 'Number of current sheet columns containing data in tracking file
Dim extraCol As Integer 'Number of current sheet columns containing data in tracking file
Dim indexRow As Long 'Row index
Dim helpRow As Long '
Dim AddIn As Integer
Dim selectedCount As Integer
Dim int1 As Long
Dim int2 As Integer
Dim int3 As Integer
'General application settings
Application.ScreenUpdating = False 'Turns off switching to exported excel file once it gets opened
Application.DisplayAlerts = False 'Turns off automatic alert messages
Application.EnableEvents = False '
Application.AskToUpdateLinks = False 'Turns off the "update links" prompt
'User prompt, choose HCP file
MsgBox "Choose TOV file missing consent information"
'Alternative way to open the file
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
'Assign a number for the selected file
Dim FileChosen As Integer
FileChosen = fd.Show
If FileChosen <> -1 Then
'Didn't choose anything (clicked on CANCEL)
MsgBox "No file selected - aborted"
End 'Ends file fetch and whole sub
End If
Dim fss As Object
Set fss = CreateObject("Scripting.FilesystemObject")
inputFile = Dir(fd.SelectedItems(1)) 'parses only the name of file
Directory = fss.getParentFolderName(fd.SelectedItems(1)) & "\" 'parses only directory of the file
'Open HCP file .xlsx spreadsheet
Set wbkTemp = Workbooks.Open(Filename:=Directory & inputFile)
'Set wbkTemp = Workbooks(Workbooks.Count)
'Get number of columns in the HCP file
colCount = wbkTemp.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
'Get the number of rows in the HCP file
intLastRow = wbkTemp.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Set GCM_ID format to number
wbkTemp.Sheets(1).Range(wbkTemp.Sheets(1).Cells(2, 1), wbkTemp.Sheets(1).Cells(intLastRow, 1)).Select 'Specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
'Prompt user for the second file
MsgBox "Select file(s) containing Consent information"
'Open Consent file dialog
Dim filedial As FileDialog
Set filedial = Application.FileDialog(msoFileDialogOpen)
Dim chosen As Integer
chosen = filedial.Show
If chosen <> -1 Then
'Didn't choose anything (clicked on CANCEL)
MsgBox "No file selected - aborted"
End 'Ends file fetch and whole sub
End If
'Number of selected files
selectedCount = filedial.SelectedItems.Count
'Extra variable
AddIn = 0
For Selected = 1 To selectedCount
'Open file with Consent info
Consent_name = Dir(filedial.SelectedItems(Selected))
'Consent_folder
Workbooks.OpenText Filename:=Consent_name, StartRow:=1, DataType:=xlDelimited, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|"
Set Consent = Workbooks(Workbooks.Count)
'Number of rows in consent file
rwCount = Consent.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Specify the column to paste data
extraCol = colCount + AddIn + 1
'1)
'VLOOKUP across spreadsheets for consent data
'wbkTemp.Sheets(1).Cells(1, 1).Copy
'wbkTemp.Sheets(1).Cells(1, extraCol).PasteSpecial Paste:=xlPasteFormats
'wbkTemp.Sheets(1).Cells(1, extraCol).Value = "Consent"
'With wbkTemp.Sheets(1)
'.Range(.Cells(2, extraCol), .Cells(intLastRow, extraCol)).Value = Application.WorksheetFunction.VLookup(.Range(.Cells(2, 1), .Cells(intLastRow, 1)).Value, Consent.Sheets(1).Range("B:J"), 8, False)
'End With
'2)
'VLOOKUP across spreadsheets for consent data
'wbkTemp.Sheets(1).Cells(1, 1).Copy
'wbkTemp.Sheets(1).Cells(1, extraCol).PasteSpecial Paste:=xlPasteFormats
'wbkTemp.Sheets(1).Cells(1, extraCol).Value = "Consent"
'With wbkTemp.Sheets(1)
' '.Range(.Cells(2, extraCol), .Cells(intLastRow, extraCol)).Value = Application.WorksheetFunction.VLookup(.Range(.Cells(2, 1), .Cells(intLastRow, 1)).Value, Consent.Sheets(1).Range("B:J"), 8, False)
' For int1 = 2 To intLastRow
' if Application.WorksheetFunction.IsNA(Application.WorksheetFunction.VLookup(.Cells()))
'
' Next int1
'End With
'3)
'VLOOKUP across spreadsheets for consent data
wbkTemp.Sheets(1).Cells(1, 1).Copy
wbkTemp.Sheets(1).Cells(1, extraCol).PasteSpecial Paste:=xlPasteFormats
wbkTemp.Sheets(1).Cells(1, extraCol).Value = "Consent"
wbkTemp.Sheets(1).Cells(1, extraCol + 2).Value = "Effective Date"
wbkTemp.Sheets(1).Cells(1, extraCol + 3).Value = "End Date"
With wbkTemp.Sheets(1)
.Range(.Cells(2, extraCol), .Cells(intLastRow, extraCol)).Value = Application.WorksheetFunction.VLookup(.Range(.Cells(2, 4), .Cells(intLastRow, 4)), Consent.Sheets(1).Range("B:J"), 8, False)
.Range(.Cells(2, extraCol + 2), .Cells(intLastRow, extraCol + 2)).Value = Application.WorksheetFunction.VLookup(.Range(.Cells(2, 4), .Cells(intLastRow, 4)), Consent.Sheets(1).Range("B:N"), 12, False)
.Range(.Cells(2, extraCol + 3), .Cells(intLastRow, extraCol + 3)).Value = Application.WorksheetFunction.VLookup(.Range(.Cells(2, 4), .Cells(intLastRow, 4)), Consent.Sheets(1).Range("B:N"), 13, False)
End With
'Close the file with consent information
Consent.Close
'Loop again for next file
AddIn = AddIn + 1
Next Selected
'Deal with N/A values
With wbkTemp.Sheets(1)
For int1 = 2 To intLastRow
For int2 = 1 To selectedCount
If Not Application.WorksheetFunction.IsNA(.Cells(int1, colCount + int2).Value) Then
.Cells(int1, colCount + 1).Value = .Cells(int1, colCount + int2).Value
End If
Next int2
Next int1
End With
'Remove extra columns
With wbkTemp.Sheets(1)
.Columns(fnColumnToLetter_Split(colCount + 2) & ":" & fnColumnToLetter_Split(extraCol + selectedCount)).Delete Shift:=xlToLeft
End With
'Save and close the new workbook
With wbkTemp
'Save and close the new workbook
.SaveAs Filename:=inputFile
.Close True
End With
MsgBox "Available consent information added"
End Sub
Function fnColumnToLetter_Split(ByVal intColumnNumber As Integer)
fnColumnToLetter_Split = Split(Cells(1, intColumnNumber).Address, "$")(1)
End Function
Code:
Sub FormatDates()
Dim lastrow As Long
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlup).Row
For i = 2 To lastrow
Cells(i, 28).NumberFormat = ("dd-mm-yyyy")
Next i
End SubThanks for any assistance
