Delete not necessary column and rearrange column

N

nabilanor

New Member
Joined
Aug 26, 2022
Messages
1
Office Version
  1. 365
Platform
  1. Windows
I manage to import CSV or text files to this macro. I combine it with Module 1(please refer file attachment). The arrangement column is a little different.
I have difficulty doing this:


The data file that I want to import is below screenshot (please refer to TEST_DATA attachment)
Pic_1.png


The data will be extracted only from these fields
Pic_2.png


Finally, the result will be
Pic_3.png


VBA Code: 
Sub EditData()
'Module 1
Dim wb As Workbook
Dim ws As Worksheet
Dim nws As Worksheet
Dim LastRow As Long
Dim RangeToFilter As Range
Dim DestinationRange As Range
Dim x As Integer

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Records")

'get data from CSV file
Call ImportCSVorText

LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row


With ws
.Range("P1") = "A_Login"
.Range("Q1") = "B_custom_field: Gender"
.Range("R1") = "D_Email"
End With

' existing column
Set RangeToFilter = ws.Range("A1:R" & LastRow)

'add MY
For i = 2 To LastRow
ws.Cells(i, 16) = "MY" & ws.Cells(i, 1)

' ### calculate leading zeroes needed for ID
If Len(ws.Cells(i, 1)) < 5 Then
    Zeroes = String(5 - Len(ws.Cells(i, 1)), "0")
    Else
    Zeroes = ""
End If
'## create ID as string with zeroes
ws.Cells(i, 1) = "'" & Zeroes & ws.Cells(i, 1)
'## create ID with MY and zeroes
ws.Cells(i, 16) = "MY" & ws.Cells(i, 1)



'add @xyz.com in email ### CSV includes - if blank
If ws.Cells(i, 1).Interior.ColorIndex <> xlNone Then
ws.Cells(i, 18) = ws.Cells(i, 3) & "@xyz.com"
ElseIf ws.Cells(i, 13) = "" Or ws.Cells(i, 13) = "-" Then
ws.Cells(i, 18) = ws.Cells(i, 16) & "@xyz.com"
Else
ws.Cells(i, 18) = ws.Cells(i, 13)
End If



'change gender title
If ws.Cells(i, 2) = "Cik" Then
ws.Cells(i, 17) = "Female"
ElseIf ws.Cells(i, 2) = "Puan" Then
ws.Cells(i, 17) = "Female"
Else: ws.Cells(i, 17) = "Male"
End If

Next i


' ### changed date format

CriteriaWildCard = Format(Date, "dd/mm/yyyy")


ws.Range("T:AL").Clear


' filter inpat/expat and hypen
' filter for date after today and status
With RangeToFilter
    .AutoFilter Field:=10, Criteria1:=">=" & CriteriaWildCard, Operator:=xlOr, _
    Criteria2:="=-"
    .AutoFilter Field:=9, Criteria1:="=Active"
    .AutoFilter Field:=14, Criteria1:="=Inpat"
End With


' copy only visible cells
With ws
.Range("T1") = "G_custom_field: Employee ID"
.Range("U1") = "P_Title"
.Range("V1") = "B_Firstname"
.Range("W1") = "C_Lastname"
.Range("X1") = "I_custom_field: Position"
.Range("Y1") = "L_custom_field: Category"
.Range("Z1") = "K_custom_field: Department"
.Range("AA1") = "O_Location"
.Range("AB1") = "F_Active"
.Range("AC1") = "N_custom_field: Last day of work"
.Range("AD1") = "J_custom_field: Date Joined"
.Range("AE1") = "M_custom_field: Line Manager"
.Range("AF1") = "P_Business_Email_Address"
.Range("AG1") = "Q_Expat/Inpat"
.Range("AH1") = "R_Job_Description"
.Range("AI1") = "A_Login"
.Range("AJ1") = "H_custom_field: Gender"
.Range("AK1") = "D_Email"
.Range("AL1") = "E_User-type"
End With

' new existing column
Set DestinationRange = ws.Range("T2:AL2")

ws.Range("A2", ws.Range("A2").End(xlToRight).End(xlDown)).SpecialCells(xlCellTypeVisible) _
.Copy Destination:=DestinationRange


' clear filter
RangeToFilter.AutoFilter

ws.Range("P:R").Clear

Set nws = wb.Worksheets.Add


' set user-type
Dim LRow3 As Long

LRow3 = ws.Cells(Rows.Count, 20).End(xlUp).Row

For e = 2 To LRow3
  
    ws.Cells(e, 38) = ws.Cells(e, 20)
    Select Case ws.Cells(e, 20)
        Case "00133"
           ws.Cells(e, 38) = "SuperAdmin"
        Case "00012"
           ws.Cells(e, 38) = "Instructor"
        Case Else
           ws.Cells(e, 38) = "Learner"
    End Select
 Next e



'rearrange column
Dim arry As Variant
arry = Array("A_Login", "B_Firstname", "C_Lastname", "D_Email", "E_User-Type", "F_Active", _
"G_custom_field: Employee ID", "H_custom_field: Gender", "I_custom_field: Position", "J_custom_field: Date Joined", _
"K_custom_field: Department", "L_custom_field: Category", "M_custom_field: Line Manager", _
"N_custom_field: Last day of work", "O_Location", "P_Title", "P_Business_Email_Address", _
"Q_Expat/Inpat", "R_Job_Description")


For j = 0 To UBound(arry)
Dim ColNo As Long
ColNo = Application.WorksheetFunction.Match(arry(j), ws.Range("A1:AL1"), 0)
ws.Columns(ColNo).Copy Destination:=nws.Columns(j + 1)

Next j

nws.Range("O:S").Clear

Dim nwsLastRow As Long
nwsLastRow = nws.Cells(Rows.Count, 1).End(xlUp).Row
nwsLastColumn = nws.Cells(1, Columns.Count).End(xlToLeft).Column


'change Active status
For k = 2 To nwsLastRow
If nws.Cells(k, 6) = "Active" Then
nws.Cells(k, 6) = "Yes"
ElseIf nws.Cells(k, 6) = "Inactive" Then
nws.Cells(k, 6) = "Yes"
Else: nws.Cells(k, 6) = "No"
End If
If nws.Cells(k, 14) = "-" Then
nws.Cells(k, 14) = ""
Else: nws.Cells(k, 14) = nws.Cells(k, 14)
 End If


'set date format #### changed date format
 nws.Cells(k, 10) = Format(nws.Cells(k, 10), "dd/mm/yyyy")
 If nws.Cells(k, 14) <> "" Then
 nws.Cells(k, 14) = Format(nws.Cells(k, 14), "dd/mm/yyyy")
 Else: nws.Cells(k, 14) = ""
 End If
Next k



For m = 1 To nwsLastColumn
nws.Cells(1, m) = Right(nws.Cells(1, m), Len(nws.Cells(1, m)) - 2)
Next m


'set font size and autofit all columns
With nws
.Cells.Font.Size = 9
.Columns.AutoFit
End With


ws.Range("T:AL").Clear

'set sheet name and date format
nws.Name = "Filter #" & wb.Worksheets.Count - 1
nws.Range("J:J").NumberFormat = "dd/mm/yyyy"
nws.Range("J:J").HorizontalAlignment = xlLeft
nws.Cells.Interior.ColorIndex = xlNone


End Sub

VBA Code: 
Sub ImportCSVorText()
'Module 2
Dim fileToOpen As Variant
Dim fileFilterPattern As String
Dim wsMaster As Worksheet
Dim wbTextImport As Workbook


fileFilterPattern = "Text Files (*.txt; *.csv), *.txt; *.csv"
fileToOpen = Application.GetOpenFilename(fileFilterPattern)

If fileToOpen = False Then
        MsgBox "No file selected"
    Else
    Application.ScreenUpdating = False
    
    Workbooks.OpenText _
        Filename:=fileToOpen, _
        StartRow:=1, _
        DataType:=xlDelimited, _
        Comma:=True
    Set wbTextImport = ActiveWorkbook
    Set wsMaster = ThisWorkbook.Worksheets("Records")
    
    wsMaster.UsedRange.Clear
    
    wbTextImport.Worksheets(1).UsedRange.Copy wsMaster.Range("A1")
    wbTextImport.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
End If

End Sub

Module 2 is the code to import a chosen CSV file. Module 1 is the code for filtering.

I'm stuck with this and need your guidance.


My raw data:

EmployeeIDTitleFirst NameMiddle NameLast NameHobbyPosition TitlePosition Entry DateStore/Depot/HOStore IDDepartment DescriptionLocationPayroll StatusLeave DateStart DateLine Manager NameLine Manager Employee IDBusiness Email AddressCountry Of EmploymentExpat/InpatPermanent ContractorBirth PlaceDate Of BirthMobile No.Job_DepartmentJob_DeptDescrJob_CodeJob_Code_Descr
00012CikVivian-LeeReadingCustomer Director
########​
Office-CustomerHead OfficeActive-
########​
Abu Bakery
1414​
vivian.lee@xyzMYInpatPermanentJohor
########​
6.01E+10​
H009200000CustomerH0268Marketing Director
00016EncikAndi-LauTravellingCustomer Director
01-Jul-17​
Office-CustomerHead OfficeActive-
########​
Abu Bakery
1414​
andi.lau@xyzMYInpatPermanentKedah
03-Jan-74​
6.01E+10​
H009200001CustomerH0269Marketing Director
00017PuanAmy-SearchCyclingCustomer Director
########​
Office-CustomerHead OfficeActive-
########​
Abu Bakery
1414​
-MYInpatPermanentSabah
########​
6.01E+10​
H009200002CustomerH0270Marketing Director
00028PuanSuki-LowReadingCustomer Director
########​
Office-ClothingHead OfficeActive-
########​
Jacky Chan
15​
-MYInpatPermanentSarawak
########​
6.01E+10​
H009200003ClothingH0271Marketing Director
00035CikBillie-ElishReadingSupport Service
########​
Office-ClothingHead OfficeActive-
########​
Jacky Chan
15​
-MYInpatPermanentMelaka
########​
6.01E+10​
H009200004ClothingS0351Service Support
22611785TuanParkpoom-PoomTravellingSupport Service
########​
Office-Service & AdminHead OfficeInactive
########​
########​
-Parkpoom.poom@xyzMYExpatPermanentPerlis
25-Jul-82​
6.01E+10​
S001030018Service & AdminS0352Service Support
23500611PuanAtiva-PeroduaTravellingSupport Service
18-Oct-12​
Office-Service & AdminHead OfficeActive-
18-Oct-12​
-Ativa@xyz.comMYExpatPermanentPerak
########​
6.01E+10​
S001030019Service & AdminS0353Service Support
24000263CikHyundai-HondaCyclingSupport Service
01-Jan-19​
Store
1010​
Service & AdminHead OfficeInactive
13-Jul-22​
########​
Joe Doe
565​
hyundai.honda@xyzMYInpatPermanentKelantan
22-Jan-90​
6.01E+10​
S001030020Service & AdminS0354Service Support
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
That will be an easy modification of the Recorded Macro.
PowerQuery/New Data Import can do this easier though the deployment is a little different. You can Copy a Query from a template/existing file to another file very easily. Having a macro available for a frequently used action can be convenient.
 
Upvote 0
You must log in or register to reply here.

Similar threads

WERNER SLABBERT
  • Question Question
Run-time error 70 after code changed
Replies
3
Views
116
RoryA
RoryA
S
  • Solved
Diagonal Sum in excel table via VBA code
2
Replies
11
Views
511
myall_blues
myall_blues
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
197
rsolanki
R
Guna13
  • Locked
  • Question Question
Need Help Deleting Empty Columns Based on Condition in Excel Spreadsheet by VBA code
2
Replies
12
Views
1K
Fluff
Fluff
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
541
VanGirl
V

Forum statistics

Threads
1,224,813
Messages
6,181,117
Members
453,021
Latest member
Justyna P

Share this page

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