Extra subroutine to crop values of one column to 10 characters

Retroshift

Board Regular
Joined
Sep 20, 2016
Messages
119
Office Version
  1. 2019
Platform
  1. Windows
Hi,
I have this macro (see below - code scripting credited to member rlv01) and I would like to add a subroutine which crops all the values of column O to 10 characters only.
So I want to only keep the first 10 characters of the data in every cell of the single column O. For example: if the macro imports "16/05/2022 11:00:00" into a cell in column O, the amount of characters should get cropped down to only the date (10 characters in this case) and not the time, so "16/05/2022".
And when a value of "16/05/2022" gets imported (merely the date (10 characters)), it is fine and it can stay there without any VBA action to it.
I am not a VBA virtuoso so any help with the scripting would be appreciated.

VBA Code:
Sub RefreshClearCopyColumnsData()
    Dim wkBk As Workbook, wkBk2 As Workbook
    Dim wkSht As Worksheet, wkSht2 As Worksheet
    Dim FullPathName As String
    Dim ColArr, ColLetter
    Dim rng As Range
    Dim I As Long, lastrow As Long
    
    'First refresh the open workbook to update all the values
    
    Set wkBk = ActiveWorkbook
    wkBk.RefreshAll
    
    'Then clear the contents of the worksheet in the open workbook
    Set wkSht = wkBk.Worksheets("Sheet1")
    wkSht.UsedRange.ClearContents
    
    'Then get columns data from closed workbook into open workbook
    'Get path and Closed Workbook filename from (indirect?) cell A5 in open workbook
    
    FullPathName = wkBk.Worksheets("Sheet2").Range("A5").Value
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(FullPathName) Then
            MsgBox "File does not exist - abort"
            Exit Sub
        End If
    End With

    Set wkBk2 = Workbooks.Open(FullPathName)
    Set wkSht2 = wkBk2.Sheets(1)
    lastrow = wkSht2.UsedRange.Rows.Count
    
    'Specify the columns until the last row with data
    ColArr = Array("A", "O", "R", "V", "AD", "AG", "AH")
    
    For Each ColLetter In ColArr
        With wkSht2
            I = I + 1
            If I = 1 Then
                Set rng = Application.Intersect(.UsedRange, .Range(ColLetter & "1", .Range(ColLetter & lastrow)))
            Else
                Set rng = Application.Union(rng, Application.Intersect(.UsedRange, .Range(ColLetter & "1", .Range(ColLetter & lastrow))))
            End If
        End With
    Next ColLetter
    
    wkSht.Activate
    rng.Copy wkSht.Range("C2")
    wkBk2.Close False
    
    'Add message box
    MsgBox "Data successfully imported"
End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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
Back
Top