(Góc nhờ giúp đỡ) Lấy dữ liệu từ nhiều file excel trong 1 folder

vinhchine123 · 29/6/22

Em chào mọi người. Em có 1 folder " Thông tin tờ khai" muốn tổng hợp dữ liệu của 4 mục em highlight vàng vào 1 file excel như ảnh ạ .
Mọi người giúp e với ạ. Em cảm ơn ạ!

Maika8008 · 29/6/22

Thấy viết "góc giúp đỡ" tưởng bạn giúp ai, hoá ra nhờ giúp. Thế thì phải viết là nhờ giúp.

vinhchine123 · 29/6/22

Maika8008 đã viết:
Thấy viết "góc giúp đỡ" tưởng bạn giúp ai, hoá ra nhờ giúp. Thế thì phải viết là nhờ giúp.

thank bác em đã sửa rồi ạ ^^

Thóc Sama · 29/6/22

vinhchine123 đã viết:
Em chào mọi người. Em có 1 folder " Thông tin tờ khai" muốn tổng hợp dữ liệu của 4 mục em highlight vàng vào 1 file excel như ảnh ạ .
Mọi người giúp e với ạ. Em cảm ơn ạ!View attachment 278062

Bạn thử kiểm tra xem đúng ý không nhé!

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    Txt = Wb.Name
    a = a + 1
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sheets("ToKhaiNhap2").Cells(41, 10)
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

vinhchine123 · 29/6/22

THÓC SAMA đã viết:

Bạn thử kiểm tra xem đúng ý không nhé!

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    Txt = Wb.Name
    a = a + 1
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sheets("ToKhaiNhap2").Cells(41, 10)
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Em cảm ơn bác, đúng ý em rồi ạ

vinhchine123 · 29/6/22

THÓC SAMA đã viết:

Bạn thử kiểm tra xem đúng ý không nhé!

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    Txt = Wb.Name
    a = a + 1
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sheets("ToKhaiNhap2").Cells(41, 10)
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Bác cho em hỏi thêm là em muốn bỏ 2 kí tự đầu trong ô cần lấy dữ liệu thì thêm code gì vào ạ. Em xin cảm ơn ạ

Thóc Sama · 29/6/22

vinhchine123 đã viết:
Bác cho em hỏi thêm là em muốn bỏ 2 kí tự đầu trong ô cần lấy dữ liệu thì thêm code gì vào ạ. Em xin cảm ơn ạ

Bạn muốn bỏ ở ô nào thì đưa ví dụ lên ha!

vinhchine123 · 29/6/22

THÓC SAMA đã viết:
Bạn muốn bỏ ở ô nào thì đưa ví dụ lên ha!

em cần bỏ ở ô số hóa đơn này ạ

Thóc Sama · 29/6/22

vinhchine123 đã viết:
em cần bỏ ở ô số hóa đơn này ạ
View attachment 278075

Tôi cũng đoán thế
Sửa lại code một chút

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String, Sv$
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    'Txt = Wb.Name
    a = a + 1
    Sv = Application.WorksheetFunction.Trim(Mid(Sheets("ToKhaiNhap2").Cells(41, 10), 4, 100))
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sv
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

vinhchine123 · 29/6/22

THÓC SAMA đã viết:

Tôi cũng đoán thế
Sửa lại code một chút

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String, Sv$
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    'Txt = Wb.Name
    a = a + 1
    Sv = Application.WorksheetFunction.Trim(Mid(Sheets("ToKhaiNhap2").Cells(41, 10), 4, 100))
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sv
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Cảm ơn bác nhiều, đúng ý em rồi ạ

vinhchine123 · 29/6/22

THÓC SAMA đã viết:

Tôi cũng đoán thế
Sửa lại code một chút

Mã:

Sub Tong_Hop()
Dim Wb As Workbook, Res(), a As Long
Dim fso As Object, Item, Txt As String, Sv$
ReDim Res(1 To 10000, 1 To 4)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Sheet1.Range("A3:D10000") = ""
'_____________________________________
On Error Resume Next
'_____________________________________
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File"
        Exit Sub
    End If
For Each Item In .SelectedItems
Set Wb = Workbooks.Open(Item)
    'Txt = Wb.Name
    a = a + 1
    Sv = Application.WorksheetFunction.Trim(Mid(Sheets("ToKhaiNhap2").Cells(41, 10), 4, 100))
    Res(a, 1) = Sheets("ToKhaiNhap2").Cells(4, 5)
    Res(a, 2) = Sheets("ToKhaiNhap2").Cells(8, 7)
    Res(a, 3) = Sv
    Res(a, 4) = Sheets("ToKhaiNhap2").Cells(123, 14)
Wb.Close False
Next
End With
With Sheet1
    .Range("A3:D10000") = ""
    .Range("A3:A10000").NumberFormat = "#"
    .Range("A3").Resize(10000, 4).Value = Res
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Bác cho em hỏi thêm, em có chạy thử thấy có lỗi ngày tháng khác nhau format, dù trong tờ khai định dạng vẫn đầy đủ số. Em đang cần đầy đủ theo dạng 20/06/2022 hh:mm:ss

Thóc Sama · 29/6/22

vinhchine123 đã viết:
Bác cho em hỏi thêm, em có chạy thử thấy có lỗi ngày tháng khác nhau format, dù trong tờ khai định dạng vẫn đầy đủ số. Em đang cần đầy đủ theo dạng 20/06/2022 hh:mm:ssView attachment 278076

Bạn sửa

Mã:

.Range("A3:A10000").NumberFormat = "#"

thành:

Mã:

.Range("A3:D10000").NumberFormat = "#"

vinhchine123 · 29/6/22

em sửa như này đúng chưa, em chạy thì ko đúng dạng

Thóc Sama · 29/6/22

vinhchine123 đã viết:
em sửa như này đúng chưa, em chạy thì ko đúng dạng
View attachment 278095

Bạn thay “#” thành “@“ xem sao

vinhchine123 · 29/6/22

THÓC SAMA đã viết:
Bạn thay “#” thành “@“ xem sao

được rồi ạ, cảm ơn bác

(Góc nhờ giúp đỡ) Lấy dữ liệu từ nhiều file excel trong 1 folder

vinhchine123

Thành viên mới

File đính kèm

Maika8008

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

vinhchine123

Thành viên mới

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

File đính kèm

vinhchine123

Thành viên mới

vinhchine123

Thành viên mới

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

vinhchine123

Thành viên mới

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

vinhchine123

Thành viên mới

vinhchine123

Thành viên mới

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

vinhchine123

Thành viên mới

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

vinhchine123

Thành viên mới

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