Mở thử mục chứa nhiều file và copy từ nhiều file vào sheet (1 người xem)

[0167767]

Chào các bạn thành viên GPE mình có 1 file excel dùng để tổng hợp các file excel mà giáo viên chủ nhiệm gửi về cho mình, để cho công việc được nhanh gọn hơn các bạn giúp mình 1 đoạn code để copy các file đó. Mời các bạn mở file giúp mình cảm ơn nhiều ạ.

 

[chuot0106]

Chào các bạn thành viên GPE mình có 1 file excel dùng để tổng hợp các file excel mà giáo viên chủ nhiệm gửi về cho mình, để cho công việc được nhanh gọn hơn các bạn giúp mình 1 đoạn code để copy các file đó. Mời các bạn mở file giúp mình cảm ơn nhiều ạ.

Bạn xem đã đúng ý bạn chưa nhé!

 

[giaiphap]

Chào các bạn thành viên GPE mình có 1 file excel dùng để tổng hợp các file excel mà giáo viên chủ nhiệm gửi về cho mình, để cho công việc được nhanh gọn hơn các bạn giúp mình 1 đoạn code để copy các file đó. Mời các bạn mở file giúp mình cảm ơn nhiều ạ.

Cách làm của mình hơi gà một chút nhưng hy vọng giúp ích cho bạn. Hãy để tệp tin THU.xls vào cùng thư mục với các file cần lấy dữ liệu

 

[0167767]

Bạn xem đã đúng ý bạn chưa nhé!

Cách làm của mình hơi gà một chút nhưng hy vọng giúp ích cho bạn. Hãy để tệp tin THU.xls vào cùng thư mục với các file cần lấy dữ liệu

Cảm ơn 2 bạn đều đúng ý mình. Cách bạn cũng ghê vậy.

 

[doveandrose]

sao các bạn lại thức khuya như vẩy ? sao code của mình chạy chậm quá . hic

Public Sub hell()
Dim fso As Object, pFile, filename, sAdr As String, lr As Long
Set fso = CreateObject("Scripting.FileSystemObject")
pFile = Application.GetOpenFilename("Excel FIles(*.xls),*.xls*", , , , True)
With Sheet2
    If TypeName(pFile) = "Variant()" Then
        .Range("B7:J10000").ClearContents
        For Each filename In pFile
            sAdr = "'" & fso.GetParentFolderName(filename) & "\[" & _
            fso.GetFileName(filename) & "]THU'!B7:J106"
            sAdr = "=if(" & sAdr & "="""",""""," & sAdr & ")"
            .Range("AA1").Resize(100, 9).FormulaArray = sAdr
            lr = .Range("AA1:AA110").Find("", , xlValues).Row - 1
            .Range("B65000").End(xlUp).Offset(1).Resize(lr, 9).Value = .Range("AA1:AI" & lr).Value
        Next
        .Range("AA1").Resize(100, 9).ClearContents
    End If
End With
End Sub

 

[giaiphap]

sao các bạn lại thức khuya như vẩy ? sao code của mình chạy chậm quá . hic

Public Sub hell()
Dim fso As Object, pFile, filename, sAdr As String, lr As Long
Set fso = CreateObject("Scripting.FileSystemObject")
pFile = Application.GetOpenFilename("Excel FIles(*.xls),*.xls*", , , , True)
With Sheet2
    If TypeName(pFile) = "Variant()" Then
        .Range("B7:J10000").ClearContents
        For Each filename In pFile
            sAdr = "'" & fso.GetParentFolderName(filename) & "\[" & _
            fso.GetFileName(filename) & "]THU'!B7:J106"
            sAdr = "=if(" & sAdr & "="""",""""," & sAdr & ")"
            .Range("AA1").Resize(100, 9).FormulaArray = sAdr
            lr = .Range("AA1:AA110").Find("", , xlValues).Row - 1
            .Range("B65000").End(xlUp).Offset(1).Resize(lr, 9).Value = .Range("AA1:AI" & lr).Value
        Next
        .Range("AA1").Resize(100, 9).ClearContents
    End If
End With
End Sub

Đỉnh luôn. Hôm nay uống cafe nhiều quá không ngủ được

 

[Quang_Hải]

Góp vui:
Cũng nên dùng thêm cách lấy hết tên file trong folder rồi dùng ADO hốt dữ liệu

Sub Main()
Dim sArr(), i As Long
GetFileList ThisWorkbook.Path, sArr
For i = 1 To UBound(sArr)
   MsgBox sArr(i)
Next
End Sub
Sub GetFileList(Path As String, sArr())
Dim ObjFile As Object, X As Long
With CreateObject("Scripting.FileSystemObject")
   For Each ObjFile In .GetFolder(Path).Files
      If ObjFile.Name <> ThisWorkbook.Name Then
         X = X + 1
         ReDim Preserve sArr(1 To X)
         sArr(X) = ObjFile
      End If
   Next
End With
End Sub

 

[doveandrose]

Góp vui:
Cũng nên dùng thêm cách lấy hết tên file trong folder rồi dùng ADO hốt dữ liệu

Sub Main()
Dim sArr(), i As Long
GetFileList ThisWorkbook.Path, sArr
For i = 1 To UBound(sArr)
   MsgBox sArr(i)
Next
End Sub
Sub GetFileList(Path As String, sArr())
Dim ObjFile As Object, X As Long
With CreateObject("Scripting.FileSystemObject")
   For Each ObjFile In .GetFolder(Path).Files
      If ObjFile.Name <> ThisWorkbook.Name Then
         X = X + 1
         ReDim Preserve sArr(1 To X)
         sArr(X) = ObjFile
      End If
   Next
End With
End Sub

anh ơi , anh nói 2 việc mà anh mới làm có 1 việc , còn cái kia anh "quên" chưa làm . xin anh làm nốt cho đàn em học tập với . hi hi

 

[Quang_Hải]

anh ơi , anh nói 2 việc mà anh mới làm có 1 việc , còn cái kia anh "quên" chưa làm . xin anh làm nốt cho đàn em học tập với . hi hi

Góp vui thôi chứ bài này mà dùng cây đao này thì cũng không nên. Ta chỉ cần quan tâm đến Sub Main là được rồi

Sub Main()
Dim Sarr(), i As Long, DataRange As String, Res()
GetFileList ThisWorkbook.Path, Sarr
DataRange = "[THU$B7:J1000]"
For i = 1 To UBound(Sarr)
   GetData Sarr(i), DataRange, Res()
   Sheets("THU").[B65536].End(3)(2).Resize(UBound(Res) + 1, UBound(Res, 2) + 1) = Res
Next
End Sub
Sub GetFileList(Path As String, Sarr())
Dim ObjFile As Object, x As Long
With CreateObject("Scripting.FileSystemObject")
   For Each ObjFile In .GetFolder(Path).Files
      If ObjFile.Name <> ThisWorkbook.Name Then
         x = x + 1
         ReDim Preserve Sarr(1 To x)
         Sarr(x) = ObjFile
      End If
   Next
End With
End Sub
Public Sub GetData(StrPath, DataRange, Des())
Dim ObjConn As Object, RS As Object, StrRequest As String
Set RS = CreateObject("ADODB.Recordset")
Set ObjConn = GetExcelConnection(StrPath)
StrRequest = "SELECT * From " & DataRange
RS.Open StrRequest, ObjConn, 3, 1
Des = TransArr(RS.Getrows)
Set ObjConn = Nothing
Set RS = Nothing
End Sub
Public Function GetExcelConnection(ByVal Path As String)
Dim StrConn As String, ObjConn As Object, Pro As String, Ext As String
Set ObjConn = CreateObject("ADODB.Connection")
Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
Ext = ";Extended Properties=""Excel 8.0;"
StrConn = Pro & "Data Source=" & Path & Ext & "HDR=No" & ";IMEX=1"";"
ObjConn.Open StrConn
Set GetExcelConnection = ObjConn
End Function
Public Function TransArr(Sarr As Variant) As Variant
Dim tmpArr As Variant, x As Long, y As Long
ReDim tmpArr(UBound(Sarr, 2), UBound(Sarr, 1))
For x = 0 To UBound(Sarr, 2)
    For y = 0 To UBound(Sarr, 1)
        tmpArr(x, y) = Sarr(y, x)
    Next y
Next x
TransArr = tmpArr
End Function

 

[0167767]

Cảm ơn các bạn, như code của các bạn copy dữ liệu từ B7:J100. Bây giờ mình muốn nới rộng thêm vùng từ B7:Q100 thì code như thế nào vậy các bạn? các bạn giúp mình tiếp nhé. cảm ơn các bạn nhiều.