Excel spreadsheet macros streamline workflows, significantly boosting productivity by automating repetitive tasks and complex calculations, allowing users to focus on data analysis and decision-making.
Macro asks the user to provide path to the import folder with CSV files and presents usable data about translation project wordcounts.
Estimated time saved: 1h daily
Sub ExtractDataFromCSVAnalysisFiles()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim dataRange As Range
Dim targetWorkbook As Workbook
Dim targetSheet As Worksheet
Dim targetCell As Range
Dim lastRow As Long
Dim i As Long
Dim sortRange As Range
Dim cell As Range
Dim originalText As String
Dim truncatedText As String
Dim delimiterPosition As Long
Dim secondDelimiterPosition As Long
Dim pattern As String
Dim currentDatePrefix As String
Dim firstRowRange As Range
' STEP 0: ACTIVATE THE FIRST SHEET Main_MACRO IN CSV_Analysis FILE
' Activate the workbook
Set targetWorkbook = Workbooks("CSV_Analysis.xlsm")
targetWorkbook.Activate
' Activate the sheet in the specified workbook
Set targetSheet = targetWorkbook.Sheets("Main_MACRO")
targetSheet.Activate
' STEP 1: PROMPT USER FOR FOLDER WITH CSV FILES AND COPY LAST ROW OF C TO I
' Prompt user to select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Else
' User canceled, exit the macro
Exit Sub
End If
End With
' Set the target sheet where you want to paste the extracted data
Set targetSheet = ThisWorkbook.Sheets("Main_MACRO") ' Change "Sheet1" to your desired sheet name
' Set the target cell where you want to paste the extracted data
Set targetCell = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
' Reset target sheet
targetSheet.Cells.Clear
' Disable screen updating to improve performance
Application.ScreenUpdating = False
' Loop through all files in the specified folder
fileName = Dir(folderPath & "*.csv")
Do While fileName <> ""
' Open each workbook
Set wb = Workbooks.Open(folderPath & fileName)
' Assuming the data is in the first sheet; change if necessary
Set ws = wb.Sheets(1)
' Define the range to copy: last row of (C to I)
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Set dataRange = ws.Range("C" & lastRow & ":I" & lastRow)
' Copy the data
targetCell.Resize(1, dataRange.Columns.Count).Value = dataRange.Value
' Paste the file name into cell I
targetCell.Offset(0, 8).Value = fileName
' Close the workbook without saving changes
wb.Close SaveChanges:=False
' Move the target cell down
Set targetCell = targetCell.Offset(1, 0)
' Get the next file name
fileName = Dir
Loop
' STEP 2: EXTRACT LANGUAGE CODES
' Find the last row with data in column I
lastRow = Cells(Rows.Count, "I").End(xlUp).Row
' Loop through each row from 2 to the last row
For i = 2 To lastRow
' Copy the last 9 characters from column I to column H
Cells(i, "H").Value = Right(Cells(i, "I").Value, 9)
Next i
' Set the worksheet where your data is located
Set ws = ThisWorkbook.Sheets("Main_MACRO")
' STEP 3: REMOVE EXTENSIONS FROM LANG CODES
' Find the last row with data in column H
lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
' Loop through each cell in column H from row 1 to the last row
For i = 1 To lastRow
' Check if the cell is not empty before processing
If Not IsEmpty(ws.Cells(i, "H").Value) Then
' Remove the last 4 characters from the cell value
ws.Cells(i, "H").Value = Left(ws.Cells(i, "H").Value, Len(ws.Cells(i, "H").Value) - 4)
End If
Next i
' STEP 4: GET SHORT FILE NAMES FOR SORTING
' Define the range in Column I (adjust the row numbers as needed)
Dim sourceRange As Range
Set sourceRange = Range("I1:I10000") ' Change the range as needed
' Define the destination range in Column J (adjust the row numbers as needed)
Dim destinationRange As Range
Set destinationRange = Range("J1:J10000") ' Change the range as needed
' Copy data from source to destination
sourceRange.Copy destinationRange
' Loop through each cell in Column I
For Each cell In Columns("I").Cells
' Check if the cell is not empty
If Not IsEmpty(cell.Value) Then
' Get the original text in the cell
originalText = cell.Value
' Find the position of the first "_"
firstDelimiterPosition = InStr(1, originalText, "_")
' Find the position of the second "_"
If firstDelimiterPosition > 0 Then
secondDelimiterPosition = InStr(firstDelimiterPosition + 1, originalText, "_")
' If second delimiter found, truncate the text
If secondDelimiterPosition > 0 Then
truncatedText = Left(originalText, secondDelimiterPosition - 1)
cell.Value = truncatedText
End If
End If
End If
Next cell
' STEP 5: CHANGE LANG CODES TO THREE LETTERS
' Set the worksheet (change "Sheet1" to your actual sheet name)
Set ws = ThisWorkbook.Sheets("Main_MACRO")
' Find the last row with data in column H
lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
' Loop through each cell in column H
For Each cell In ws.Range("H1:H" & lastRow)
' Check and replace based on the provided table
Select Case cell.Value
Case "ar_AE"
cell.Value = "ARA"
Case "bg_BG"
cell.Value = "BUL"
Case "cs_CZ"
cell.Value = "CZE"
' Add more cases for other replacements based on the provided table
Case "da_DK"
cell.Value = "DAN"
Case "de_DE"
cell.Value = "GER"
Case "el_GR"
cell.Value = "GRE"
Case "es_ES"
cell.Value = "SPA"
Case "et_EE"
cell.Value = "EST"
Case "fi_FI"
cell.Value = "FIN"
Case "fr_FR"
cell.Value = "FRE"
Case "he_IL"
cell.Value = "HEB"
Case "hr_HR"
cell.Value = "CRO"
Case "hu_HU"
cell.Value = "HUN"
Case "it_IT"
cell.Value = "ITA"
Case "ja_JP"
cell.Value = "JPN"
Case "lt_LT"
cell.Value = "LIT"
Case "lv_LV"
cell.Value = "LAV"
Case "nb_NO"
cell.Value = "NOR"
Case "nl_NL"
cell.Value = "DUT"
Case "pl_PL"
cell.Value = "POL"
Case "pt_BR"
cell.Value = "BPO"
Case "pt_PT"
cell.Value = "RUM"
Case "ro_RO"
cell.Value = "RUS"
Case "ru_RU"
cell.Value = "SLK"
Case "sk_SK"
cell.Value = "SLV"
Case "sl_SI"
cell.Value = "POR"
Case "sr_SP"
cell.Value = "SRB"
Case "sv_SE"
cell.Value = "SWE"
Case "tr_TR"
cell.Value = "TUR"
Case "uk_UA"
cell.Value = "UKR"
' Add more cases for other replacements based on the provided table
End Select
Next cell
' STEP 6: SORT BY LANG CODE AND SHORT FILE NAME
' Change the sheet name and range as needed
Set sortRange = Sheets("Main_MACRO").Range("A1:Z10000")
' Sort the range by Column H (8th column)
With sortRange
.Sort Key1:=.Columns(8), Order1:=xlAscending, Header:=xlYes
End With
' Sort the range by Column I (9th column)
With sortRange
.Sort Key1:=.Columns(9), Order1:=xlAscending, Header:=xlYes
End With
' STEP 7: COPY COLUMN J TO K
' Find the last row with data in column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Copy values from column J to column K
ws.Range("J1:J" & lastRow).Copy Destination:=ws.Range("K1")
' STEP 8: TRUNCATE FILE NAME TO EXTRACT SUGGESTED FOLDER NAME (USING PATTERN DELIMITER OF "-" FOLLOWED BY 7 DIGITS, E.G. "-1234567"
' Find the last row with data in column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Loop through each cell in column J
For Each cell In ws.Range("J1:J" & lastRow)
' Initialize variables
delimiterPosition = 1
pattern = ""
' Loop to find and truncate text after each hyphen
Do While delimiterPosition > 0
' Find the position of the hyphen ("-") in the cell
delimiterPosition = InStr(delimiterPosition, cell.Value, "-")
' If a hyphen is found, extract the pattern and check its format
If delimiterPosition > 0 Then
pattern = Mid(cell.Value, delimiterPosition + 1, 7)
' Check if the pattern has exactly 7 digits
If IsNumeric(pattern) And Len(pattern) = 7 Then
' Truncate text after the hyphen and 7 digits
cell.Value = Left(cell.Value, delimiterPosition + Len(pattern))
End If
' Move the delimiterPosition to the next character
delimiterPosition = delimiterPosition + 1
End If
Loop
Next cell
' STEP 9: TRUNCATE LAST 8 CHARACTERS FROM COLUMN J
' Find the last row with data in column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Loop through each cell in column J
For Each cell In ws.Range("J1:J" & lastRow)
' Check if the cell has at least 8 characters
If Len(cell.Value) >= 8 Then
' Truncate the last 8 characters
cell.Value = Left(cell.Value, Len(cell.Value) - 8)
Else
' If the cell has fewer than 8 characters, clear the cell
cell.ClearContents
End If
Next cell
' STEP 10: ADD DATE TO THE BEGINNING OF FOLDER NAME
' Find the last row with data in column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Get the current date in the format YYYYMMDD
currentDatePrefix = Format(Now(), "YYYYMMDD") & "_"
' Loop through each cell in column J
For Each cell In ws.Range("J2:J" & lastRow)
' Append the current date prefix to the beginning of the string
cell.Value = currentDatePrefix & cell.Value
Next cell
' *****************************************TIDY UP THE COLUMNS FOR BETTER COPY/PASTING
' STEP 11: REMOVE COLUMN I
' Delete Column I
ws.Columns("I").Delete
' STEP 12: ADD TWO NEW COLUMNS
' Insert two columns on the left
ws.Columns("A:B").Insert Shift:=xlToRight
' STEP 13: COPY COLUMN K TO A
' Find the last row with data in column K
lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
' Copy values from column K to column A
ws.Range("K1:K" & lastRow).Copy Destination:=ws.Range("A1")
' STEP 14: COPY COLUMN J TO B1
' Find the last row with data in column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Copy values from column J to column B
ws.Range("J1:J" & lastRow).Copy Destination:=ws.Range("B1")
' STEP 15: REMOVE COLUMN J TWICE
' Delete Column J
ws.Columns("J").Delete
' Delete Column J
ws.Columns("J").Delete
' STEP 16: COPY COLUMN A TO K
' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Copy values from column A to column K
ws.Range("A1:A" & lastRow).Copy Destination:=ws.Range("K1")
' STEP 17: REMOVE DUPLICATES FROM COLUMN K
' Find the last row with data in column K
lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
' Remove duplicates from column K
ws.Range("K1:K" & lastRow).RemoveDuplicates Columns:=1, Header:=xlYes
' STEP 18: ADD HEADERS TO THE TOP OF THE FILE
' Update the values in the first row cells
ws.Range("A1").Value = "Project name"
ws.Range("B1").Value = "Lang Code"
ws.Range("C1").Value = "Total"
ws.Range("D1").Value = "ICE Match"
ws.Range("E1").Value = "100%"
ws.Range("F1").Value = "100-95%"
ws.Range("G1").Value = "95-75%"
ws.Range("H1").Value = "75-0%"
ws.Range("I1").Value = "Repetition"
ws.Range("J1").Value = "Reference file name"
ws.Range("K1").Value = "Suggested folder names"
' STEP 19: AUTO WIDEN COLUMNS FOR VISIBLITY
' Auto widen columns A to K
ws.Columns("A:K").AutoFit
' STEP 20: ADD FORMATTING TO FIRST ROW
' Set the range for the first row (change "K" to your last column if needed)
Set firstRowRange = ws.Range("A1:K1")
' Change the background color to black
firstRowRange.Interior.Color = RGB(0, 0, 0) ' RGB values for black
' Change the font color to white
firstRowRange.Font.Color = RGB(255, 255, 255) ' RGB values for white
' STEP 21: CENTRE LANG CODE COLUMN B
' Center-align the content in column B
Columns("B:I").HorizontalAlignment = xlCenter
' STEP 22: REMOVE COLUMN K WITH SUGGESTED FOLDER NAMES AS NO LONGER NEEDED
' Delete Column I
ws.Columns("K").Delete
' STEP 23: APPLY FILTER TO TOP ROW
' Check if AutoFilter is already applied
If ws.AutoFilterMode = False Then
' Apply AutoFilter to the top row
ws.Rows(1).AutoFilter
End If
' STEP 24: SORT BY NAME
' Sort the entire data range (adjust the range as needed)
ws.Range("A1:K10000").Sort Key1:=ws.Range("A1"), Order1:=xlAscending, Header:=xlYes
' LAST STEP:
' Re-enable screen updating
Application.ScreenUpdating = True
End SubUser copy pastes data into the macro, then launches macro. Product is selected from the list, path provided to an invoice template used by the customer. Data is transferred over to the template.
Estimated time saved: 2h monthly
Sub UI_and_DOC()
' Declare variables
Dim selectedOption As String
Dim ws As Worksheet
Dim lastRow As Long
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim lastSourceRow As Long
Dim lastDestinationRow As Long
Dim targetRange As Range
' STEP 0: Select product
' Prompt the user to select an option
selectedOption = InputBox("Select an option:", "Options", "Analytics")
' STEP 1: Filter column A by selectedOption and B by "UI!
' Set the worksheet
Set ws = ThisWorkbook.Sheets("Invoice_creation")
' Turn off existing AutoFilter
ws.AutoFilterMode = False
' Set AutoFilter to the first row
ws.Rows(1).AutoFilter
' Filter column A by selectedOption
ws.Range("A:A").AutoFilter Field:=1, Criteria1:=selectedOption
' Filter column B by "UI"
ws.Range("A:B").AutoFilter Field:=2, Criteria1:="UI"
' STEP 2: Copy handoff names to User Interface tab
' Set the source and destination sheets
Set sourceSheet = ThisWorkbook.Sheets("Invoice_creation")
Set destinationSheet = ThisWorkbook.Sheets("User_Interface")
' Clear the contents of the User_Interface sheet (excluding the first row)
destinationSheet.Rows("2:" & destinationSheet.Rows.Count).Clear
' Find the last row with data in source column C
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row
' Find the last row with data in destination column A
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("C2:C" & lastSourceRow).Copy
destinationSheet.Range("A" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 3: Copy dates to UI tab
' Find the last row with data in source column E
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "E").End(xlUp).Row
' Find the last row with data in destination column B
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("E2:E" & lastSourceRow).Copy
destinationSheet.Range("B" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' Apply the date format directly to the target range
Set targetRange = destinationSheet.Columns("B")
targetRange.NumberFormat = "mm/dd/yyyy"
' STEP 4: copy lang codes to UI tab
' Find the last row with data in source column D
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
' Find the last row with data in destination column C
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "C").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("D2:D" & lastSourceRow).Copy
destinationSheet.Range("C" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 5: copy wordcounts to UI tab
' Find the last row with data in source columns G to M
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "G").End(xlUp).Row
' Find the last row with data in destination columns D to J
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "D").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("G2:M" & lastSourceRow).Copy
destinationSheet.Range("D" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 6: change filter to "DOC"
' Set the worksheet
Set ws = ThisWorkbook.Sheets("Invoice_creation")
' Filter column B by "DOC"
ws.Range("A:B").AutoFilter Field:=2, Criteria1:="DOC"
' STEP 7: copy handoff names from C to Documentation tab
' Set the source and destination sheets
Set sourceSheet = ThisWorkbook.Sheets("Invoice_creation")
Set destinationSheet = ThisWorkbook.Sheets("Documentation")
' Clear the contents of the User_Interface sheet (excluding the first row)
destinationSheet.Rows("2:" & destinationSheet.Rows.Count).Clear
' Find the last row with data in source column C
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row
' Find the last row with data in destination column A
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("C2:C" & lastSourceRow).Copy
destinationSheet.Range("A" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 8: copy dates
' Find the last row with data in source column E
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "E").End(xlUp).Row
' Find the last row with data in destination column B
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("E2:E" & lastSourceRow).Copy
destinationSheet.Range("B" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' Apply the date format directly to the target range
Set targetRange = destinationSheet.Columns("B")
targetRange.NumberFormat = "mm/dd/yyyy"
' STEP 9: copy lang codes
' Find the last row with data in source column D
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
' Find the last row with data in destination column C
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "C").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("D2:D" & lastSourceRow).Copy
destinationSheet.Range("C" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 10: copy wordcounts to DOC tab
' Find the last row with data in source columns G to M
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "G").End(xlUp).Row
' Find the last row with data in destination columns D to J
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "D").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("G2:M" & lastSourceRow).Copy
destinationSheet.Range("D" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 11: copy help testing values to DOC
' Find the last row with data in source column N
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "N").End(xlUp).Row
' Find the last row with data in destination column M
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "M").End(xlUp).Row
' Copy data from source to destination (excluding headers)
If lastSourceRow > 1 Then
sourceSheet.Range("N2:N" & lastSourceRow).Copy
destinationSheet.Range("M" & lastDestinationRow + 1).PasteSpecial xlPasteValues
End If
' STEP 12: centre columns B and C in UI and DOC
Set ws = ThisWorkbook.Sheets("User_Interface") ' Replace "User_Interface" with the actual sheet name
' Center the contents of columns B and C
ws.Columns("B:C").HorizontalAlignment = xlCenter
Set ws = ThisWorkbook.Sheets("Documentation") ' Replace "User_Interface" with the actual sheet name
' Center the contents of columns B and C and M
ws.Columns("B:C").HorizontalAlignment = xlCenter
ws.Columns("M:M").HorizontalAlignment = xlCenter
' STEP 13: Open up target invoice template and copy UI and DOC to the target file (set font to Arial 10)
' Set the source workbook and sheet
Set sourceWorkbook = Workbooks("Invoice_creation.xlsm")
Set sourceSheet = sourceWorkbook.Sheets("User_Interface")
' Ask user for the existing workbook path
newPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx")
' Check if the user canceled the file dialog
If newPath = "False" Then
Exit Sub
End If
' Open the existing workbook
Set targetWorkbook = Workbooks.Open(newPath)
Set targetSheet = targetWorkbook.Sheets("User_Interface")
' Clear contents in the target sheet
targetSheet.Cells.Clear
' Copy data from source to target
sourceSheet.UsedRange.Copy Destination:=targetSheet.Range("A1")
' Set font in the target sheet to Arial 10
targetSheet.Cells.Font.Name = "Arial"
targetSheet.Cells.Font.Size = 10
' Set the source sheet
Set sourceSheet = sourceWorkbook.Sheets("Documentation")
' Set the target sheet
Set targetSheet = targetWorkbook.Sheets("Documentation")
' Clear contents in the target sheet
targetSheet.Cells.Clear
' Copy data from source to target
sourceSheet.UsedRange.Copy Destination:=targetSheet.Range("A1")
' Set font in the target sheet to Arial 10
targetSheet.Cells.Font.Name = "Arial"
targetSheet.Cells.Font.Size = 10
' STEP 14: copy the billing values into target invoice
' Activate the "Billing" sheet in the target workbook
targetWorkbook.Sheets("Billing").Activate
' Find selectedOption in column A of source sheet "Billing"
Dim findValue As Range
Set findValue = sourceWorkbook.Sheets("Billing").Columns("A:A").Find(What:=selectedOption, LookIn:=xlValues)
' If selectedOption is found, copy values from columns B and C in the same row to target sheet "Billing"
If Not findValue Is Nothing Then
Dim sourceRow As Long
sourceRow = findValue.Row
targetWorkbook.Sheets("Billing").Range("D2").Value = sourceWorkbook.Sheets("Billing").Cells(sourceRow, "B").Value
targetWorkbook.Sheets("Billing").Range("E2").Value = sourceWorkbook.Sheets("Billing").Cells(sourceRow, "C").Value
End If
End SubExported data is copied into the macro. It then asks for path to a second file, containing software details for each job. It combines two exports together, providing usable result.
Estimated time saved: 1h weekly (two merges)
Sub Sort_exported_data()
' STEP 1: SORT ITEMS BY COLUMN A
Dim lastRow As Long
Dim sortRange As Range
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set sortRange = Range("A1:S" & lastRow)
With ActiveSheet.Sort
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange sortRange ' Corrected line
.Header = xlYes
.Apply
End With
' STEP 2: REMOVE NOT NEEDED COLUMNS
' remove column C, F, G, I, J, L, M, N, O, Q, R, S
Range("C:C,F:F,G:G,I:I,J:J,M:M,N:N,O:O,Q:Q,R:R,S:S").Delete
' STEP 3: OPEN SECOND FILE, SORT IT BY COLUMNS E AND C, COPY COLUMN Q TO THE CURRENT FILE
Dim filePath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
' Prompt user to open file
filePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx")
' Check if user selected a file
If filePath <> "False" Then
' Open the selected workbook
Set wbSource = Workbooks.Open(filePath)
Set wsSource = wbSource.Sheets(1) ' Assuming data is in the first sheet, change accordingly
' Reference the active sheet in the current workbook
Set wsDestination = ThisWorkbook.ActiveSheet
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set sortRange = Range("A1:S" & lastRow)
With ActiveSheet.Sort
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange sortRange ' Corrected line
.Header = xlYes
.Apply
End With
' Copy column Q from the source worksheet to the destination worksheet
wsSource.Range("Q:Q").Copy wsDestination.Range("I1")
' Close the source workbook without saving changes
wbSource.Close False
Else
MsgBox "No file selected. Operation canceled.", vbExclamation
End If
' STEP 4: CONVERT COLUMN I TO SEPARATE COLUMNS USING DELIMITER ","
Dim ws As Worksheet
Dim cell As Range
Dim textToSplit As String
Dim splitValues As Variant
' Set the worksheet
Set ws = ThisWorkbook.Sheets(1) ' Change "Sheet1" to your actual sheet name
' Find the last row in Column I
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
' Loop through each cell in Column I
For Each cell In ws.Range("I1:I" & lastRow)
' Get the text from the cell
textToSplit = cell.Value
' Check if the cell contains a comma
If InStr(textToSplit, ",") > 0 Then
' Split the text using the comma as a delimiter
splitValues = Split(textToSplit, ",")
' Determine the number of columns needed
Dim numColumns As Integer
numColumns = UBound(splitValues) + 1
' Resize the destination range to fit the split values
cell.Offset(0, 1).Resize(1, numColumns).Value = splitValues
End If
Next cell
' STEP 5: REMOVE NOT NEEDED COLUMNS
' remove columns
Range("I:I,J:J,K:K,L:L,M:M,N:N,P:P,Q:Q,R:R,T:T,U:U").Delete
' STEP 6: SPLIT COLUMN I USING DELIMITER ":"
' Find the last row in Column I
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
' Loop through each cell in Column I
For Each cell In ws.Range("I1:I" & lastRow)
' Get the text from the cell
textToSplit = cell.Value
' Check if the cell contains a colon
If InStr(textToSplit, ":") > 0 Then
' Split the text using the colon as a delimiter
splitValues = Split(textToSplit, ":")
' Resize the destination range to fit the split values (Columns K and L)
cell.Offset(0, 3).Resize(1, UBound(splitValues) + 1).Value = splitValues
End If
Next cell
' STEP 7: SPLIT COLUMN J DELIMITER ":"
' Find the last row in Column J
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
' Loop through each cell in Column J
For Each cell In ws.Range("J1:J" & lastRow)
' Get the text from the cell
textToSplit = cell.Value
' Check if the cell contains a colon
If InStr(textToSplit, ":") > 0 Then
' Split the text using the colon as a delimiter
splitValues = Split(textToSplit, ":")
' Resize the destination range to fit the split values (Columns M and N)
cell.Offset(0, 4).Resize(1, UBound(splitValues) + 1).Value = splitValues
End If
Next cell
' STEP 8: SPLIT COLUMN K DELIMITER ":"
' Find the last row in Column K
lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
' Loop through each cell in Column K
For Each cell In ws.Range("K1:K" & lastRow)
' Get the text from the cell
textToSplit = cell.Value
' Check if the cell contains a colon
If InStr(textToSplit, ":") > 0 Then
' Split the text using the colon as a delimiter
splitValues = Split(textToSplit, ":")
' Resize the destination range to fit the split values (Columns M and N)
cell.Offset(0, 5).Resize(1, UBound(splitValues) + 1).Value = splitValues
End If
Next cell
' STEP 9: REMOVE NOT NEEDED COLUMNS
' remove columns
Range("I:I,J:J,K:K,L:L,N:N,P:P").Delete
' STEP 10: REMOVE DOUBLE QUOTES FROM COLUMNS I TO K
' Find the last row in Column I
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
' Define the range to include Columns I, J, and K
Set Rng = ws.Range("I1:K" & lastRow)
' Loop through each cell in the defined range
For Each cell In Rng
' Check if the cell contains double quotes
If InStr(cell.Value, """") > 0 Then
' Replace double quotes with an empty string
cell.Value = Replace(cell.Value, """", "")
End If
Next cell
' STEP 11: REMOVE "}" FROM COLUMN K
' Find the last row in Column K
lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
' Define the range for Column K
Set Rng = ws.Range("K1:K" & lastRow)
' Loop through each cell in Column K
For Each cell In Rng
' Check if the cell contains the closing curly brace
If InStr(cell.Value, "}") > 0 Then
' Replace the closing curly brace with an empty string
cell.Value = Replace(cell.Value, "}", "")
End If
Next cell
' STEP 12: WIDEN CELLS E AND H TO FIT VALUES
' Set the range for Column E
Set columnToWiden = ws.Columns("E")
' Widen Column E to fit the text
columnToWiden.AutoFit
' Set the range for Column H
Set columnToWiden = ws.Columns("H")
' Widen Column H to fit the text
columnToWiden.AutoFit
' STEP 13: REMOVE LINES THAT CONTAIN ko-KR, zh-Hans AND zh-Hant USING COLUMN D
Dim deleteRange As Range
' Find the last row in Column D
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
' Define the range for Column D
Set Rng = ws.Range("D1:D" & lastRow)
' Loop through each cell in Column D
For Each cell In Rng
' Check if the cell contains "ko-KR", "zh-Hans", or "zh-Hant"
If InStr(1, cell.Value, "ko-KR") > 0 Or InStr(1, cell.Value, "zh-Hans") > 0 Or InStr(1, cell.Value, "zh-Hant") > 0 Then
' Add the entire row to the delete range
If deleteRange Is Nothing Then
Set deleteRange = cell.EntireRow
Else
Set deleteRange = Union(deleteRange, cell.EntireRow)
End If
End If
Next cell
' Delete the entire rows in the delete range
If Not deleteRange Is Nothing Then
deleteRange.Delete
End If
End Sub