[VBA] Extract the folder names from a path

[zeromax1]

Dear all expert. I have a question about how to extract the different folder name from a path?

I use an VBA to get the file name & path from the servers.

For example:

C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\2020\PLS.xlsx

C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\HIJKLMN LIMITED (HIJK)\2020\PLS.xlsx

C:\Users\user.defg\ABC Group\Accounting Folder - DOC Library\Google LIMITED (GLG)\2021\PLS.xlsx

C:\Users\user.beg\ABC Group\Accounting Folder - DOC Library\Apple (APP)\2021\PLS.xlsx

May I know are there possible to extract the Company Name & Year to different columns?

Company Name	Year
ABCDEFG LTD (abcd)	2020
HIJKLMN LIMITED (HIJK)	2020
Google LIMITED (GLG)	2021
Apple (APP)	2021

Many thanks for all of you if possible to advise any solution.

 

[Akuini]

Try this:

Sub a1158542a()
Dim i As Long
Dim va, vb, x

va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 2)

For i = 2 To UBound(va, 1)
    x = Split(va(i, 1), "\")
   
        If UBound(x) > 2 Then
            vb(i, 1) = x(UBound(x) - 2)
            vb(i, 2) = x(UBound(x) - 1)
        End If
       
Next

Range("B1").Resize(UBound(vb, 1), 2) = vb
End Sub

de Userform template-example-sample.xlsm
	A	B	C
1	data
2	C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\2020\PLS.xlsx	ABCDEFG LTD (abcd)	2020
3	C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\HIJKLMN LIMITED (HIJK)\2020\PLS.xlsx	HIJKLMN LIMITED (HIJK)	2020
4	C:\Users\user.defg\ABC Group\Accounting Folder - DOC Library\Google LIMITED (GLG)\2021\PLS.xlsx	Google LIMITED (GLG)	2021
5	C:\Users\user.beg\ABC Group\Accounting Folder - DOC Library\Apple (APP)\2021\PLS.xlsx	Apple (APP)	2021
Sheet3

 

[zeromax1]

Hi Akuini, Thank you for your prompt reply. One more question about how to modified the code for longer path?


If my file path become longer than before like this:

C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\2020\PLS.xlsx

C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\PIC Name\2020\11-20\List.xlsx

The company name will extract 2020 instead of ABCDEFG LTD (abcd).

Try this:

Sub a1158542a()
Dim i As Long
Dim va, vb, x

va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 2)

For i = 2 To UBound(va, 1)
    x = Split(va(i, 1), "\")
  
        If UBound(x) > 2 Then
            vb(i, 1) = x(UBound(x) - 2)
            vb(i, 2) = x(UBound(x) - 1)
        End If
      
Next

Range("B1").Resize(UBound(vb, 1), 2) = vb
End Sub

 

[Akuini]

What the result should look like for this?
C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\PIC Name\2020\11-20\List.xlsx

 

[zeromax1]

What the result should look like for this?
C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\PIC Name\2020\11-20\List.xlsx

It extract 2020 and 11-20. But I still want to extract the ABCDEFG LTD(abcd).

 

[Akuini]

It extract 2020 and 11-20. But I still want to extract the ABCDEFG LTD(abcd).

So "PIC Name" is ignored?
What criteria do you use to pick up "ABCDEFG LTD (abcd)" but not "PIC Name"?

 

[zeromax1]

So "PIC Name" is ignored?
What criteria do you use to pick up "ABCDEFG LTD (abcd)" but not "PIC Name"?

The pattern for the below path is fixed:

Only the text with red colour will be changed base on the users and the company.

C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\Company Name\

Is it possible to only extract the company name? Then I can modified the code to extract the other text.

 

[Akuini]

Try this:

Sub a1158542b()
Dim i As Long
Dim va, vb, x

va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)

For i = 2 To UBound(va, 1)
    x = Split(va(i, 1), "\")
        If UBound(x) > 4 Then
            vb(i, 1) = x(5)
        End If
Next

Range("B1").Resize(UBound(vb, 1), 1) = vb
End Sub

Book1
	A	B
1	data
2	C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\2020\PLS.xlsx	ABCDEFG LTD (abcd)
3	C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\HIJKLMN LIMITED (HIJK)\2020\PLS.xlsx	HIJKLMN LIMITED (HIJK)
4	C:\Users\user.defg\ABC Group\Accounting Folder - DOC Library\Google LIMITED (GLG)\2021\PLS.xlsx	Google LIMITED (GLG)
5	C:\Users\user.beg\ABC Group\Accounting Folder - DOC Library\Apple (APP)\2021\PLS.xlsx	Apple (APP)
6	C:\Users\user.abc\ABC Group\Accounting Folder - DOC Library\ABCDEFG LTD (abcd)\PIC Name\2020\11-20\List.xlsx	ABCDEFG LTD (abcd)
Sheet5

 

[zeromax1]

Excellent! Thank you very much.

Try this:

Sub a1158542b()
Dim i As Long
Dim va, vb, x

va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)

For i = 2 To UBound(va, 1)
    x = Split(va(i, 1), "\")
        If UBound(x) > 4 Then
            vb(i, 1) = x(5)
        End If
Next

Range("B1").Resize(UBound(vb, 1), 1) = vb
End Sub

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.