Code tách tên file

thoai · 18/2/19

Mình có code (listfile) chọn file bất kỳ trong thư mục và liệt kê ra đường dẫn file từ cell A1 trở xuống. Mình muốn code hiệu chỉnh sao cho khi liệt kê ra đường dẫn file sẽ theo trình tự file (D:\user\bao cáo tổng hợp)
A1: D:\
B1: D:\user
C1: báo cáo tổng hợp
Tiếp tục cho các file khác từ Cell A2...

snow25 · 19/2/19

thoai đã viết:
Mình có code (listfile) chọn file bất kỳ trong thư mục và liệt kê ra đường dẫn file từ cell A1 trở xuống. Mình muốn code hiệu chỉnh sao cho khi liệt kê ra đường dẫn file sẽ theo trình tự file (D:\user\bao cáo tổng hợp)
A1: D:\
B1: D:\user
C1: báo cáo tổng hợp
Tiếp tục cho các file khác từ Cell A2...

Mình chỉ tách được vậy thôi.Tách thế kia lâu lắm.Bạn xem có được không.

Mã:

Sub listfile()
Dim xls As Excel.Worksheet
Dim fd As FileDialog
Dim vItem As Variant, T, a As Integer, max As Integer, b As Integer, j As Integer
Dim mg1 As Range
Dim mg2 As Range
Dim source As String
Dim i As Long, arr_res()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set xls = ActiveSheet
With fd
    .Filters.Add "All Files", "*.docx;*.doc;*.xls;*.xlsx;*.jpg; *.jpeg", 1
    .FilterIndex = 1
    .AllowMultiSelect = True
    If .Show = -1 Then
        For i = 1 To .SelectedItems.Count
            b = b + 1
            T = Split("/" & .SelectedItems.Item(i), "\")
            a = UBound(T)
            If a > max Then
               max = a
               ReDim Preserve arr_res(1 To .SelectedItems.Count, 1 To max)
            End If
            For j = 1 To a
                  arr_res(b, j) = T(j)
            Next j
        Next
        [a1].Resize(b, max).Value = arr_res()
    End If
End With
  Set fd = Nothing
End Sub

vanthinh3101 · 19/2/19

thoai đã viết:
Mình có code (listfile) chọn file bất kỳ trong thư mục và liệt kê ra đường dẫn file từ cell A1 trở xuống. Mình muốn code hiệu chỉnh sao cho khi liệt kê ra đường dẫn file sẽ theo trình tự file (D:\user\bao cáo tổng hợp)
A1: D:\
B1: D:\user
C1: báo cáo tổng hợp
Tiếp tục cho các file khác từ Cell A2...

Bạn thử code sau:

Mã:

Sub listfile()
    Dim xls As Excel.Worksheet
    Dim fd As FileDialog
    Dim vItem As Variant
    Dim mg1 As Range
    Dim mg2 As Range
    Dim source As String
    Dim i As Long, arr_res()
    Dim Tmp, Str As String, j As Long
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Set xls = ActiveSheet
    With fd
        .Filters.Add "All Files", "*.docx;*.doc;*.xls;*.xlsx;*.jpg; *.jpeg", 1
        .FilterIndex = 1
        .AllowMultiSelect = True
        
        If Not .Show = -1 Then MsgBox "Ban chua chon file", vbCritical, "GPE": Exit Sub
      
        For i = 1 To .SelectedItems.Count
            Tmp = Split(.SelectedItems.Item(i), "\")
            ReDim Preserve arr_res(1 To .SelectedItems.Count, 1 To UBound(Tmp))
            Str = Tmp(0)
            For j = 1 To UBound(Tmp)
                Str = Str & "\" & Tmp(j)
                'Debug.Print Str
                arr_res(i, j) = Str
            Next j
        Next
        [a1].Resize(UBound(arr_res), UBound(Tmp)) = arr_res
    End With
      Set fd = Nothing
End Sub

thoai · 19/2/19

vanthinh3101 đã viết:

Bạn thử code sau:

Mã:

Sub listfile()
    Dim xls As Excel.Worksheet
    Dim fd As FileDialog
    Dim vItem As Variant
    Dim mg1 As Range
    Dim mg2 As Range
    Dim source As String
    Dim i As Long, arr_res()
    Dim Tmp, Str As String, j As Long
   
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Set xls = ActiveSheet
    With fd
        .Filters.Add "All Files", "*.docx;*.doc;*.xls;*.xlsx;*.jpg; *.jpeg", 1
        .FilterIndex = 1
        .AllowMultiSelect = True
       
        If Not .Show = -1 Then MsgBox "Ban chua chon file", vbCritical, "GPE": Exit Sub
     
        For i = 1 To .SelectedItems.Count
            Tmp = Split(.SelectedItems.Item(i), "\")
            ReDim Preserve arr_res(1 To .SelectedItems.Count, 1 To UBound(Tmp))
            Str = Tmp(0)
            For j = 1 To UBound(Tmp)
                Str = Str & "\" & Tmp(j)
                'Debug.Print Str
                arr_res(i, j) = Str
            Next j
        Next
        [a1].Resize(UBound(arr_res), UBound(Tmp)) = arr_res
    End With
      Set fd = Nothing
End Sub

Nhờ bạn xem lại code: ở cột A1 là ổ đĩa, cột B1 là: thư mục và C1 là tên file. Code bạn không đúng

vanthinh3101 · 19/2/19

thoai đã viết:
Nhờ bạn xem lại code: ở cột A1 là ổ đĩa, cột B1 là: thư mục và C1 là tên file. Code bạn không đúng

Nếu trường hợp đường dẫn là: D:\user\GPE\Hoc Excel\bao cáo tổng hợp thì kết quả sẽ như thế nào bạn nhỉ?

excel_lv1.5 · 19/2/19

thoai đã viết:
Mình có code (listfile) chọn file bất kỳ trong thư mục và liệt kê ra đường dẫn file từ cell A1 trở xuống. Mình muốn code hiệu chỉnh sao cho khi liệt kê ra đường dẫn file sẽ theo trình tự file (D:\user\bao cáo tổng hợp)
A1: D:\
B1: D:\user
C1: báo cáo tổng hợp
Tiếp tục cho các file khác từ Cell A2...

Bạn thử code này:

Mã:

Sub listfile()
Dim xls As Excel.Worksheet
Dim fd As FileDialog
Dim vItem As Variant
Dim mg1 As Range
Dim mg2 As Range
Dim source As String
Dim i As Long, arr_res(): ReDim arr_res(1 To 1000, 1 To 3)
Dim fs As Object: Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set xls = ActiveSheet
With fd
    .Filters.Add "All Files", "*.docx;*.doc;*.xls;*.xlsx;*.jpg; *.jpeg", 1
    .FilterIndex = 1
    .AllowMultiSelect = True
    If .Show = -1 Then
        For i = 1 To .SelectedItems.Count
            arr_res(i, 3) = fs.getfilename(.SelectedItems(i))
            arr_res(i, 1) = fs.GetDriveName(.SelectedItems(i)) & "\"
            arr_res(i, 2) = fs.GetParentFolderName(.SelectedItems(i))
        Next
        [a1].Resize(UBound(arr_res), 3) = arr_res
    End If
End With
Set fd = Nothing
End Sub

thoai · 19/2/19

vanthinh3101 đã viết:
Nếu trường hợp đường dẫn là: D:\user\GPE\Hoc Excel\bao cáo tổng hợp thì kết quả sẽ như thế nào bạn nhỉ?

A1: d:\, b1: user, c1:gpe, d1: hoc excel, e1: bao cao mình chỉ cần a1, b1 và e1 tức thư mục ngắn thôi

vanthinh3101 · 19/2/19

thoai đã viết:
A1: d:\, b1: user, c1:gpe, d1: hoc excel, e1: bao cao mình chỉ cần a1, b1 và e1 tức thư mục ngắn thôi

Như bạn nói ở trên thì tôi lại thấy có sự khác biệt so với yêu cầu ban đầu tại bài #1.
Bạn tham khảo code ở bài #6, tôi thấy chắc là đáp ứng tốt cho bạn rồi.

Syn.nguyen · 19/2/19

Bạn thử cái tool này là OK.
Source code Delphi XE6:
procedure TForm5.Button1Click(Sender: TObject);
var
_sFileName,sc:string;
c:Integer;
begin
if OpenDialog1.Execute then
begin
_sFileName:=OpenDialog1.FileName;
end
else Exit;
c:=0;
for sc in _sFileName.Split(['\']) do
begin
if c=0 then XLSSpreadSheet1.XLS.Sheets[0].AsString[c,Loop]:=sc+'\'
else XLSSpreadSheet1.XLS.Sheets[0].AsString[c,Loop]:=sc;
Inc(c);
end;
XLSSpreadSheet1.InvalidateSheet;
Inc(loop);

thoai · 19/2/19

vanthinh3101 đã viết:
Như bạn nói ở trên thì tôi lại thấy có sự khác biệt so với yêu cầu ban đầu tại bài #1.
Bạn tham khảo code ở bài #6, tôi thấy chắc là đáp ứng tốt cho bạn rồi.

cảm ơn bạn, mình đã chỉnh dc code

Code tách tên file

thoai

Thành viên thường trực

File đính kèm

snow25

Thành viên gạo cội

vanthinh3101

Thành viên tích cực

thoai

Thành viên thường trực

vanthinh3101

Thành viên tích cực

excel_lv1.5

Thành viên tích cực

thoai

Thành viên thường trực

vanthinh3101

Thành viên tích cực

Syn.nguyen

Thành viên mới

File đính kèm

thoai

Thành viên thường trực

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian