VBA Import text file to excel with desired result

[roykana]

Dear All Master,
I want to import from text file to excel and want the desired result as below and for column H I mark yellow then the result must be text.
I also attached a text file link
thanks
roykana

DESIRED RESULT

VBA IMPORT TEXT FILE.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	No Transaction	Date	Dept.	Code Pel.	Name Customer	Address	No.	Cd. Item	Name Item	Qty	Unit	Price	Pot. %	Total	Pot. :	Tax :	Costs :	Total End :
2	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	410288	TAMAKA R 410288 RC/L-TOP	1	PCS	115000	0	115000	40000	0	0	800000
3	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		2	829740	TAMAKA R 829740 RC/L-TOP	2	PCS	90000	0	180000
4	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		3	410240	TAMAKA R 410240 RC/L-TOP	1	PCS	125000	0	125000
5	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		4	56117	ALFIN TRAVEL 56117 D1680 TG	1	PCS	105000	0	105000
6	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		5	222445	TAMAKA R 222445 RC/L-TOP/USB	1	PCS	155000	0	155000
7	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		6	111195	TAMAKA R 111195 RC/L-TOP/USB	1	PCS	160000	0	160000
8	0003/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	2019	ALFIN WB 2019 BATIK	1	PCS	35000	0	35000	0	0	0	35000
MASTER

Option Explicit

Sub Importtextfile()
    '// Declare a variable as
    Dim nRow            As Long
    Dim sExtension      As String
    Dim oFolder         As FileDialog '// FileDialog object
    Dim vSelectedItem   As Variant
    Dim wsSelect        As Worksheet
    '// Stop Screen Flickering
    Application.ScreenUpdating = False

    '// Create a FileDialog object as a File Picker dialog box
    Set oFolder = Application.FileDialog(msoFileDialogOpen)
    Set wsSelect = Sheets("MASTER")

    '// Use a With...End With block to reference FileDialog.
    With oFolder
        '// Allow multiple selection.
        .AllowMultiSelect = True
        '// Use the Show method to display the files.
        If .Show = -1 Then

    '// Extension
    sExtension = Dir("*.txt")

    '// Step through each SelectedItems
    For Each vSelectedItem In .SelectedItems

        '// Sets Row Number for Data to Begin
        nRow = Range("A1").End(xlUp).Offset(1, 0).Row
With wsSelect.Range("A1").CurrentRegion.Clear
End With
        '// Below is importing a text file
        With wsSelect.QueryTables.Add(Connection:= _
            "TEXT;" & sExtension, Destination:=Range("$A$" & nRow))
            .Name = sExtension
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = ""
            .TextFileTrailingMinusNumbers = False
            .Refresh BackgroundQuery:=False
        End With
        sExtension = Dir
    Next
            '// If Cancel...
            Else
            End If
    End With

    Application.ScreenUpdating = True

    '// Set object to Nothing. Object? see Link Object
    Set oFolder = Nothing
End Sub

link text file

 

[roykana]

You must paste this VBA demonstration to the MASTER worksheet module :​

Sub Demo1()
  Const N = "No. *"
    Dim V, F%, H, K, S, W, L&, T, R&, X
        ChDrive ThisWorkbook.Path:  ChDir ThisWorkbook.Path
    With Application
        V = .GetOpenFilename("Report files,*.txt", , "Select a file"):  If V = False Then Exit Sub
        F = FreeFile
        H = [{1,1;2,3;4,6;5,7}]
        K = [{7,1;8,2;9,3;10,8;11,9;12,10;13,11;14,12}]
        UsedRange.Offset(1).Clear
       .ScreenUpdating = False
       .ThousandsSeparator = "."
       .UseSystemSeparators = False
        Open V For Input As #F
        S = Split(Input(LOF(F), #F), vbCrLf)
        Close #F
        ReDim V(UBound(S), 1 To 18)
        W = .Match(N, S, 0)
    While IsNumeric(W)
        L = .Match("Pot. : *", S, 0) - 1
        T = .Trim(Split(S(L), vbTab))
        S(L) = "":  S(W - 1) = ""
        For L = 1 To 4:  V(R, L + 14) = T(2 + (L - 1) * 3):  Next
        T = .Trim(Split(S(W - 2), vbTab, 8))
    Do
        X = .Trim(Split(S(W), vbTab)):  If Not IsNumeric(X(1)) Then Exit Do
        For L = 1 To UBound(H):  V(R, H(L, 1)) = T(H(L, 2)):  Next
        For L = 1 To UBound(K):  V(R, K(L, 1)) = X(K(L, 2)):  Next
        R = R + 1
        W = W + 1
    Loop
        W = .Match(N, S, 0)
    Wend
    If R Then
        If .International(32) <> 1 Then
            For R = 0 To R - 1
                X = Split(V(R, 2), "/"):  If UBound(X) = 2 Then V(R, 2) = X(2) & "/" & X(1) & "/" & X(0)
            Next
        End If
        With [A2].Resize(R, UBound(V, 2))
            .Columns(8).NumberFormat = "@"
            .FormulaLocal = V
        End With
    End If
       .UseSystemSeparators = True
       .ScreenUpdating = True
    End With
End Sub

​

@Marc L
Thanks for the reply from you but there was a "run time error 424" error. Code below

        UsedRange.Offset(1).Clear

 

[Marc L]

​

As it works as expected on my side so the bad in on yours just 'cause you did not follow the post #9 direction relative to where must be pasted the code …​

​

If you want to paste it in a general module so you must add the worksheet reference.​

 

[roykana]

​

As it works as expected on my side so the bad in on yours just 'cause you did not follow the post #9 direction relative to where must be pasted the code …​

​

If you want to paste it in a general module so you must add the worksheet reference.​

@Marc L

Thanks to your reply, another one how the table autoresizes like the screenshot below so that it appears blank long rows. This is because previously I imported text files whose records are more than text file sample

VBA IMPORT TEXT FILE.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	No Transaction	Date	Dept.	Code Pel.	Name Customer	Address	No.	Cd. Item	Name Item	Qty	Unit	Price	Pot. %	Total	Pot. :	Tax :	Costs :	Total End :
2	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	410288	TAMAKA R 410288 RC/L-TOP	1	PCS	115,000	0	115,000	40,000	0	0	800,000
3	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		2	829740	TAMAKA R 829740 RC/L-TOP	2	PCS	90,000	0	180,000
4	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		3	410240	TAMAKA R 410240 RC/L-TOP	1	PCS	125,000	0	125,000
5	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		4	56117	ALFIN TRAVEL 56117 D1680 TG	1	PCS	105,000	0	105,000
6	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		5	222445	TAMAKA R 222445 RC/L-TOP/USB	1	PCS	155,000	0	155,000
7	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		6	111195	TAMAKA R 111195 RC/L-TOP/USB	1	PCS	160,000	0	160,000
8	0003/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	2019	ALFIN WB 2019 BATIK	1	PCS	35,000	0	35,000	0	0	0	35,000
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
MASTER

 

[Marc L]

​

Without the link of your workbook I could not see it was a table …​

 

[Marc L]

So the beginner level little mod :​

        .FormulaLocal = V
    End With
        ListObjects(1).Resize [A1].CurrentRegion
    End If
        .UseSystemSeparators = True

 

[Marc L]

​

Or ListObjects(1).Resize Range("A1:R" & R + 1) …​

 

[roykana]

​

Or ListObjects(1).Resize Range("A1:R" & R + 1) …​

@Marc L
if using the code above then as below and there is a line that is missing because previously I imported text files whose records are smaller

[B]ListObjects(1).Resize [A1].CurrentRegion[/B]

ListObjects(1).Resize Range("A1:R" & R + 1)

if using the code above then as below and there is a line that is missing because previously I imported text files whose records are smaller

VBA IMPORT TEXT FILE.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	No Transaction	Date	Dept.	Code Pel.	Name Customer	Address	No.	Cd. Item	Name Item	Qty	Unit	Price	Pot. %	Total	Pot. :	Tax :	Costs :	Total End :
2	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	410288	TAMAKA R 410288 RC/L-TOP	1	PCS	######	0	115,000	40,000	0	0	800,000
3	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		2	829740	TAMAKA R 829740 RC/L-TOP	2	PCS	90,000	0	180,000
4	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		3	410240	TAMAKA R 410240 RC/L-TOP	1	PCS	######	0	125,000
5	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		4	56117	ALFIN TRAVEL 56117 D1680 TG	1	PCS	######	0	105,000
6	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		5	222445	TAMAKA R 222445 RC/L-TOP/USB	1	PCS	######	0	155,000
7	0002/KSR/TK/1221	19-12-21		GENERAL	GENERAL		6	111195	TAMAKA R 111195 RC/L-TOP/USB	1	PCS	######	0	160,000
8	0003/KSR/TK/1221	19-12-21		GENERAL	GENERAL		1	2019	ALFIN WB 2019 BATIK	1	PCS	35,000	0	35,000	0	0	0	35,000
9
10	0005/KSR/TK/1221	23-12-21		UMUM	UMUM		1	57133	ALFIN R ANAK 57133 MOTIF	1	PCS	65,000	0	65,000	30,000	0	0	240,000
MASTER

 

[Marc L]

No such issue on my side as the worksheet is cleared before to import anything​

so it seems it's a guessing challenge but as guessing can't be coding, see post #6 …​

 

[roykana]

​

No such issue on my side as the worksheet is cleared before to import anything​

so it seems it's a guessing challenge but as guessing can't be coding, see post #6​

@Marc L
I added the code below so I can create a table but do you think this is appropriate or do you have other recommendations?

Sub Demo1()
  Const N = "No. *"
    Dim V, F%, H, K, S, W, L&, T, R&, X
    Dim objTable As ListObject
    Dim startTime As Double
    startTime = Timer
        ChDrive ThisWorkbook.Path:  ChDir ThisWorkbook.Path
    With Application
        V = .GetOpenFilename("Report files,*.txt", , "Select a file"):  If V = False Then Exit Sub
        F = FreeFile
        H = [{1,1;2,3;4,6;5,7}]
        K = [{7,1;8,2;9,3;10,8;11,9;12,10;13,11;14,12}]
'        UsedRange.Offset(1).Clear
       Columns("A:T").Clear
       .Range("A1") = "No Transaction"
       .Range("B1") = "Date"
       .Range("C1") = "Dept."
       .Range("D1") = "Code Pel."
       .Range("E1") = "Name Customer"
       .Range("F1") = "Address"
       .Range("G1") = "No."
       .Range("H1") = "Cd. Item"
       .Range("I1") = "Name Item"
       .Range("J1") = "Qty"
       .Range("K1") = "Unit"
       .Range("L1") = "Price"
       .Range("M1") = "Pot. %"
       .Range("N1") = "Total"
       .Range("O1") = "Pot. :"
       .Range("P1") = "Tax :"
       .Range("Q1") = "Costs :"
       .Range("R1") = "Total End :"
       .Range("S1") = "ITEM NO"
       .Range("T1") = "TOTHBNET"
              
       .ScreenUpdating = False
       .ThousandsSeparator = "."
       .UseSystemSeparators = False
        Open V For Input As #F
        S = Split(Input(LOF(F), #F), vbCrLf)
        Close #F
        ReDim V(UBound(S), 1 To 18)
        W = .Match(N, S, 0)
    While IsNumeric(W)
        L = .Match("Pot. : *", S, 0) - 1
        T = .Trim(Split(S(L), vbTab))
        S(L) = "":  S(W - 1) = ""
        For L = 1 To 4:  V(R, L + 14) = T(2 + (L - 1) * 3):  Next
        T = .Trim(Split(S(W - 2), vbTab, 8))
    Do
        X = .Trim(Split(S(W), vbTab)):  If Not IsNumeric(X(1)) Then Exit Do
        For L = 1 To UBound(H):  V(R, H(L, 1)) = T(H(L, 2)):  Next
        For L = 1 To UBound(K):  V(R, K(L, 1)) = X(K(L, 2)):  Next
        R = R + 1
        W = W + 1
    Loop
        W = .Match(N, S, 0)
    Wend
    If R Then
        If .International(32) <> 1 Then
            For R = 0 To R - 1
                X = Split(V(R, 2), "/"):  If UBound(X) = 2 Then V(R, 2) = X(2) & "/" & X(1) & "/" & X(0)
            Next
        End If
        With [A2].Resize(R, UBound(V, 2))
            .Columns(2).NumberFormat = "DD/MM/YYYY"
            .Columns(8).NumberFormat = "@"
            .FormulaLocal = V
        End With
    End If
       .UseSystemSeparators = True
       .ScreenUpdating = True
    End With
    Set wsSelect = ActiveWorkbook.Sheets("MASTER")
    wsSelect.Range("A1", "T" & wsSelect.Cells(Rows.Count, "A").End(xlUp).Row).Select
    Set objTable = wsSelect.ListObjects.Add(xlSrcRange, Selection, , xlYes)             ' Create Table
    objTable.Name = "TableText"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

 

[Marc L]

I should not comment it if you are happy with it (even if you use useless things)…​

​

According to your post #13 where the table already exists - so no need to create it ! - the combination of my post #6 VBA procedure​

with my post #16 well works on my side …​