Change case the data inside a column

Question

I created a code that import the data regularly into a selected workbook. The code run well, it takes less than 20 seconds before the data is imported successfully.

How does it work?

I get a monthly data with Excel format. I want the data to be imported into my workbook to be analysed further.

• Step by step

The first part of my code run to copy the data from monthly workbook to analysis workbook.

The second part is a macro that will copy the content from the new data imported into a template table analysis based on the header. The code will only copy the content of columns if the header between 2 tables match.

Finally, I decided to add in the middle of the body of code, only for client's name column, before the macro copies all the rows at that column. I asked it to change the case of the value for each row to be UPPERCASE.

After adding this one line of code, my code run for 20 minutes.

Can someone help me to give another solution for the code to change the case to be "UPPERCASE" and also to reduce the runtime?

Option Explicit
 Dim lastRow As Long, LastTemp As Long 'lasttemp is "last row for table template
 Const StartRowTemp As Byte = 1
 Dim c As Byte 'number of columns
 Dim GetHeader As Range 'find
 Call Entry_Point 'to prevent screen updating and display alert, the value is False
' On Error GoTo Handle
 'pick files to import - allow multiselect
 FiletoOpen = Application.GetOpenFilename _
 (FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select Workbook to Import", MultiSelect:=True)
 If IsArray(FiletoOpen) Then
 For FileCnt = 1 To UBound(FiletoOpen)
 Set SelectedBook = Workbooks.Open(Filename:=FiletoOpen(FileCnt))
 ShDataN.Cells.Clear
 SelectedBook.Worksheets("Client").Cells.Copy
 ShDataN.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
 SelectedBook.Close
 'locate last empty row in Monthly Table
 lastRow = ShMN.Cells(Rows.Count, 1).End(xlUp).Row + 1
 'locate last row in the new data
 LastTemp = ShDataN.Cells(Rows.Count, 1).End(xlUp).Row
 'delete the content from Analysis table
 ShMN.Rows("2:" & ShMN.Rows.Count).ClearContents
 'do while to find matching headers before copy paste
 c = 1
 Do While ShMN.Cells(1, c) <> ""
 Set GetHeader = ShDataN.Rows(StartRowTemp).Find _
 (What:=ShMN.Cells(1, c).Value, LookIn:=xlValues, MatchCase:=False, lookat:=xlWhole)
 If Not GetHeader Is Nothing Then
 ShDataN.Range(ShDataN.Cells(StartRowTemp + 1, GetHeader.Column), ShDataN.Cells(LastTemp, GetHeader.Column)).Copy
 ShMN.Cells(2, c).PasteSpecial
 ShMN.Rows("2:" & ShMN.Rows.Count).ClearFormats
 Call Range_Case
 'to change the case on column Client's name after copying
'
' Set myrange = ShMN.Range("B2", "B" & Cells(Rows.Count, 1).Row)
'
' For Each cell In myrange
'
' cell.Value = UCase(cell)
'
' Next cell
 End If 'get Header
 c = c + 1
 Loop
 Next FileCnt
 MsgBox "Data imported sucessfully", vbInformation, "General Information"
 End If 'isArray
 ShDataN.Cells.Clear
 With ShNote
 .Select
 .Range("A1").Select
 End With
 Call Exit_Point
'Handle:
' If Err.Number = 9 Then
' Else
' MsgBox "An error has occured"
' End If
Call Exit_Point
End Sub

• IvenBach: You have an Exit Sub but no opening Sub statement. In order to give a meaningful review we need code that can compile in order for us to run it. Please edit your question so that your provided example can compile.
• AJD: sigh Call is deprecated. Funny, if you weren't using Call, you would probably have thought of using a Function to either return a modified string or to loop through a given range changing the case of each value if appropriate.
• C.Edo: @IvenBach thanks for your comments. I forgot to delete exit sub, it was part of my previous code that I didn't use anymore. I edited my code. Can you help me please?
• IvenBach: You'll need to edit your code further. You have no Public Sub SubproceduresName indicating where your sub starts, I'm assuming immediately after Option Explicit. Because you have Option Explicit included you have to Explicitly declare all variables. ShDataN is used but never declared somewhere like Dim ShDataN as Worksheet. You need to include Entry_Point as well. Until we can copy/paste your example code and have it compile we will be unable to give an adequate review.
• Sᴀᴍ Onᴇᴌᴀ: Please see What to do when someone answers. I have rolled back Rev 5 → 4

Answer 1

For testing your code following assumption are made

1. Sub Entry_Point was disabling screen updating, events and display alerts.

2. Sub Exit_Point was enabling screen updating, events and display alerts.

3. It is being used for importing data from multiple files and to be finally placed in SheetShMN one below another

according to the above assumption following modification was done

1 Sheet ShMN is being cleared with in loop For FileCnt = 1 To UBound(FiletoOpen) with line ShMN.Rows("2:" & ShMN.Rows.Count).ClearContents. I pulled out the line out of the For loop for testing purpose.

2.The line ShMN.Cells(2, c).PasteSpecial modifed to ShMN.Cells(lastRow, c).PasteSpecial for placing data from each file one below another (This to avoid 1st files data to be overwritten by subsequent files data).

3. Finally as the cause of slow performance, it is found the Case Changing codes are placed inside header finding loop.So it is executing Number of files X Number of columns times. I pulled it out of even file loop and placed just after completion of Data import.
4. Myrange was defined "B2:B" & Rows Count. I change it to Set MyRange = ShMN.Range("B2:B" & ShMN.Cells(Rows.Count, 2).End(xlUp).Row)

For Testing purpose, I used 5 files consisting same Data of 500 rows X 52 Columns with header. I have not used Calculation mode manual, Screen update disable etc (as I generally don't prefer these). You may use the techniques as per your requirement. It takes around 50 seconds to import all 5 files data and only another 3 odd seconds to change the case of B column (in my old laptop)

My test code:

Option Explicit
Sub test()
Dim Tm As Long
Dim FiletoOpen As Variant, ShDataN As Worksheet, ShMN As Worksheet
Dim FileCnt As Long, SelectedBook As Workbook, MyRange As Range, cell As Range
Tm = Timer
Set ShDataN = ThisWorkbook.Sheets(1)
Set ShMN = ThisWorkbook.Sheets(2)
 Dim lastRow As Long, LastTemp As Long 'lasttemp is "last row for table template
 Const StartRowTemp As Byte = 1
 Dim c As Byte 'number of columns
 Dim GetHeader As Range 'find
 'Call Entry_Point 'to prevent screen updating and display alert, the value is False
 'Application.ScreenUpdating = False
 'Application.EnableEvents = False
 Application.DisplayAlerts = False
' On Error GoTo Handle
 'pick files to import - allow multiselect
 FiletoOpen = Application.GetOpenFilename _
 (FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select Workbook to Import", MultiSelect:=True)
 If IsArray(FiletoOpen) Then
 'delete the content from Analysis table
 ShMN.Rows("2:" & ShMN.Rows.Count).ClearContents ' moved out of For foleCnt loop
 For FileCnt = 1 To UBound(FiletoOpen)
 Set SelectedBook = Workbooks.Open(Filename:=FiletoOpen(FileCnt))
 ShDataN.Cells.Clear
 SelectedBook.Worksheets("Client").Cells.Copy
 ShDataN.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
 SelectedBook.Close False
 'locate last empty row in Monthly Table
 lastRow = ShMN.Cells(Rows.Count, 1).End(xlUp).Row + 1
 'locate last row in the new data
 LastTemp = ShDataN.Cells(Rows.Count, 1).End(xlUp).Row
 'do while to find matching headers before copy paste
 c = 1
 Do While ShMN.Cells(1, c) <> ""
 Set GetHeader = ShDataN.Rows(StartRowTemp).Find _
 (What:=ShMN.Cells(1, c).Value, LookIn:=xlValues, MatchCase:=False, lookat:=xlWhole)
 If Not GetHeader Is Nothing Then
 ShDataN.Range(ShDataN.Cells(StartRowTemp + 1, GetHeader.Column), ShDataN.Cells(LastTemp, GetHeader.Column)).Copy
 ShMN.Cells(lastRow, c).PasteSpecial ' row 2 modified to lastRow
 ShMN.Rows("2:" & ShMN.Rows.Count).ClearFormats
' Call Range_Case
 'to change the case on column Client's name after copying
 End If 'get Header
 c = c + 1
 Loop
 Next FileCnt
Debug.Print Timer - Tm
Dim MyArr As Variant, FinalArr() As Variant, i As Long
 Set MyRange = ShMN.Range("B2:B" & ShMN.Cells(Rows.Count, 2).End(xlUp).Row)
 'For Each cell In MyRange
 'cell.Value = UCase(cell)
 'Next cell
 MyArr = MyRange.Value
 ReDim FinalArr(LBound(MyArr, 1) To UBound(MyArr, 1))
 For i = LBound(MyArr, 1) To UBound(MyArr, 1)
 FinalArr(i) = UCase(MyArr(i, 1))
 Next
 MyRange.Value = FinalArr
 'MsgBox "Data imported sucessfully", vbInformation, "General Information"
 End If 'isArray
 ShDataN.Cells.Clear
 'With ShNote
 ' .Select
 ' .Range("A1").Select
 'End With
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Application.DisplayAlerts = True
Debug.Print Timer - Tm
End Sub

Finally I tried the case changing with arrays to minimize excel cell operations as my ethic. You may use your process (commented out). it hardly affect performance in this case.

• C.Edo: Hello, Thank you for your help. You described very well each part of my code. However, after trying your code for "Range Case" it didn't work. I will edit my original post and hope you can tell me which part that I have mistakenly written. Thank again @Ahmed AU
• C.Edo: I forgot to explain the reason behind "ShMN.Cells(lastRow, c).PasteSpecial", why I didn't put "lastrow" on the place of "2" because I didn't want the macro to bring the new data and paste it on the next empty row. To prevent the overwritten data, I put this macro "ShMN.Rows("2:" & ShMN.Rows.Count).ClearContents" before "do while function"
• C.Edo: Hello, I got the right code for change case. Thanks for your help