Joining two pieces of VBA Code. Formatting a column to Date Format

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

wkfvLle.png


Picture 2
FJPFPlg.png


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
2nd piece of code

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 Sub


Thanks for any assistance
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

DaveBlakeMAAT

Board Regular
Joined
Feb 28, 2016
Messages
187
Hi

There are 2 different approaches you can take, if the 2 pieces of code are within the sam project you could just add the following before End Sub on your main code

Code:
Call FormatDates

or just copy the following into your main code before the End Sub

Code:
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
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,388
Office Version
  1. 365
Platform
  1. Windows
Wrap the vlookup within the VBA with Cdate(application.vlookup etc etc etc)
 

Conell8383

Board Regular
Joined
Jul 26, 2016
Messages
66
@DaveBlake: Thank you for the response. It is greatly appreciated. I have tried both options with no success. I put

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 Sub

Right at the end of the 1st piece of code and I put

Code:
Call Sub FormatDates()

just after
Code:
 '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)
    
   Call FormatDates
    
    
    End With

No joy unfortunately. Is there something wrong with where I am placing and calling the code perhaps?
 

DaveBlakeMAAT

Board Regular
Joined
Feb 28, 2016
Messages
187

ADVERTISEMENT

Sorry try changing Sub FormatDates() to the following

Code:
Public Sub FormatDates()

Steve's suggestion should also work.
 

Conell8383

Board Regular
Joined
Jul 26, 2016
Messages
66
@Dave: Thank you again for the help. But again unfortunately

Code:
Public Sub FormatDates()

Did not work. Is there another amendment that can be made?
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,388
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Which column is the date column within this lot?

Code:
    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
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,388
Office Version
  1. 365
Platform
  1. Windows
If everything else is working ok then you could use it like this with additional With

Code:
    With wbkTemp.Sheets(1)
        .Cells(1, extraCol).Value = .Cells(1, 1).Value
        .Cells(1, extraCol).Value = "Consent"
        .Cells(1, extraCol + 2).Value = "Effective Date"
        .Cells(1, extraCol + 3).Value = "End Date"
        .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)
        With .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)
            .NumberFormat = "dd/mm/yyyy"
        End With
        With .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)
            .NumberFormat = "dd/mm/yyyy"
        End With
    End With
 

Conell8383

Board Regular
Joined
Jul 26, 2016
Messages
66
@Steve: Thank you for the new piece of code and the support. Unfortunately the two columns with
Code:
.NumberFormat = "dd/mm/yyyy"
at the end now produce #N/A instead of dates. Is there something missing in the code?

Thank you again for the support. It is greatly appreciated.
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,388
Office Version
  1. 365
Platform
  1. Windows
Ah I see why. This will work then.

Code:
    With wbkTemp.Sheets(1)
        .Cells(1, extraCol).Value = .Cells(1, 1).Value
        .Cells(1, extraCol).Value = "Consent"
        .Cells(1, extraCol + 2).Value = "Effective Date"
        .Cells(1, extraCol + 3).Value = "End Date"
        .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 + 2), .Cells(intLastRow, extraCol + 2)).NumberFormat = "dd/mm/yyyy"
        .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)
        .Range(.Cells(2, extraCol + 3), .Cells(intLastRow, extraCol + 3)).NumberFormat = "dd/mm/yyyy"
    End With
 

Watch MrExcel Video

Forum statistics

Threads
1,129,795
Messages
5,638,366
Members
417,023
Latest member
Zimbo38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top