Xin hỗ trợ sửa code VBA lấy dữ liệu giữa 2 file excel (1 người xem)

Linhtrantxtn đã viết:

Dạ em có 2 file excel, em có làm mã code để lấy dữ liệu dòng Tong màu vàng từ file Chi Nhu.xlsx qua file Bang tong.xlsb, em có viết mã code nhưng khi chạy chỉ hiện dữ liệu nào là giá trị nhập tay, còn ô nào là hàm công thức thì không hiện ra số, nhờ anh chị sửa giúp em để có thể hiển thị dữ liệu của các ô chứa công thức. em cảm ơn nhiều ạ!

Nhấp chuột vào đây để mở rộng...

wb.Sheets("Sheet1").Range("B11:E11").Copy wbtong.Sheets("Sheet1").Range("E6:H6")

 wb.Sheets("Sheet1").Range("B11:E11").Copy
wbtong.Sheets("Sheet1").Range("E6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False

HUONGHCKT đã viết:

Thử thay dòng:

Mã: Sao chép.

wb.Sheets("Sheet1").Range("B11:E11").Copy wbtong.Sheets("Sheet1").Range("E6:H6")

Thành

Mã: Sao chép.

 wb.Sheets("Sheet1").Range("B11:E11").Copy
wbtong.Sheets("Sheet1").Range("E6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False

xem sao

Nhấp chuột vào đây để mở rộng...

HUONGHCKT đã viết:

Thử thay dòng:

Mã: Sao chép.

wb.Sheets("Sheet1").Range("B11:E11").Copy wbtong.Sheets("Sheet1").Range("E6:H6")

Thành

Mã: Sao chép.

 wb.Sheets("Sheet1").Range("B11:E11").Copy
wbtong.Sheets("Sheet1").Range("E6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False

xem sao

Nhấp chuột vào đây để mở rộng...

Linhtrantxtn đã viết:

Dạ, em áp dụng code anh hướng dẫn và đã chạy từng file được rồi, nhưng chỉ hiển thị trên 1 dòng. Em muốn áp dụng thêm cho nhiều file cùng một lúc và hiển thị theo từng dòng nhưng báo lỗi, nhờ anh xem giúp em thêm lần nữa, em cảm ơn nhiều!

Nhấp chuột vào đây để mở rộng...

Sub copykl()
    Dim wb As Workbook, wbtong As Workbook, FileName, i As Integer, j As Integer, dong As Integer
Dim R&, Lr&, dCuoi&, t&
Dim Sh As Worksheet, Ws As Worksheet
Set wbtong = ThisWorkbook
Set Sh = Sheet1
dCuoi = Sh.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
      FileName = Application.GetOpenFilename("All,*.*", , "chon file", , True)
    For i = LBound(FileName) To UBound(FileName)
        For j = 6 To dCuoi
            If FileName(i) Like "*\" & Sh.Cells(j, 3) & ".xlsx" Then
                dong = j
                Set wb = Workbooks.Open(FileName(i))
                Set Ws = wb.Sheets("Sheet1")
                    Lr = Ws.Range("A" & Rows.Count).End(xlUp).Row
                        If Not Ws.Range("A6:A" & Lr).Find("tong") Is Nothing Then
                            R = Ws.Range("A6:A" & Lr).Find("tong").Row
                            Ws.Range("B" & R).Resize(, 4).Copy
                            Sh.Cells(dong, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            t = t + 1
                        End If
                    wb.Close False
                    Exit For
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
MsgBox " Đa lây sô liêu cua " & t & " file thành công"
End Sub

End Sub

HUONGHCKT đã viết:

Bạn thử thay code cũ bằng code này (đã sửa tý chút)

Mã: Sao chép.

Sub copykl()
    Dim wb As Workbook, wbtong As Workbook, FileName, i As Integer, j As Integer, dong As Integer
Dim R&, Lr&, dCuoi&, t&
Dim Sh As Worksheet, Ws As Worksheet
Set wbtong = ThisWorkbook
Set Sh = Sheet1
dCuoi = Sh.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
      FileName = Application.GetOpenFilename("All,*.*", , "chon file", , True)
    For i = LBound(FileName) To UBound(FileName)
        For j = 6 To dCuoi
            If FileName(i) Like "*\" & Sh.Cells(j, 3) & ".xlsx" Then
                dong = j
                Set wb = Workbooks.Open(FileName(i))
                Set Ws = wb.Sheets("Sheet1")
                    Lr = Ws.Range("A" & Rows.Count).End(xlUp).Row
                        If Not Ws.Range("A6:A" & Lr).Find("tong") Is Nothing Then
                            R = Ws.Range("A6:A" & Lr).Find("tong").Row
                            Ws.Range("B" & R).Resize(, 4).Copy
                            Sh.Cells(dong, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            t = t + 1
                        End If
                    wb.Close False
                    Exit For
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
MsgBox " Đa lây sô liêu cua " & t & " file thành công"
End Sub

End Sub

Code trên là chiều theo ý bạn nên muốn hỏi bạn là:
Tại sao bạn lại phải cho duyệt từng dòng trong Cột C của Sh1.file tong nhỉ? Sao không là: Duyệt các file đã chọn lấy luôn tên file ấy vào cột C của sh1/file tổng

Nhấp chuột vào đây để mở rộng...

Linhtrantxtn đã viết:

Dạ em cảm ơn anh đã hỗ trợ nhiệt tình, em đã áp dụng và đã chạy thành công file rồi ạ.
Còn lý do em chọn từng dòng là vì em đang học hỏi tập viết code nên không nghĩ đến vấn đề lấy tên file trực tiếp. Nhờ anh hỏi em mới nghĩ đến vấn đề này, vậy trong bảng code trên nếu lấy tên file thì mình cần điều chỉnh code chỗ nào nữa, nhờ anh chỉ giúp để em học hỏi thêm luôn anh nhé , cảm ơn anh nhiều lắm!

Nhấp chuột vào đây để mở rộng...

Sub copykl()
    Dim wb As Workbook, wbtong As Workbook, FileName, i As Integer, j As Integer, dong As Integer
Dim R&, Lr&, dCuoi&, S, TenFile As String
Dim Sh As Worksheet, Ws As Worksheet, Rng As Range
Dim KQ()
Set wbtong = ThisWorkbook
Set Sh = Sheet1
dCuoi = Sh.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
    FileName = Application.GetOpenFilename("All,*.*", , "chon file", , True)
ReDim KQ(1 To UBound(FileName), 1 To 6)
    For i = LBound(FileName) To UBound(FileName)
            Set wb = Workbooks.Open(FileName(i))
                S = Split(Dir(FileName(i)), ".")
                TenFile = S(1)
            Set Ws = wb.Sheets("Sheet1")
                Lr = Ws.Range("A" & Rows.Count).End(xlUp).Row
                If Not Ws.Range("A6:A" & Lr).Find("tong") Is Nothing Then
                    R = Ws.Range("A6:A" & Lr).Find("tong").Row
                    Set Rng = Ws.Range("B" & R).Resize(, 4)
                    t = t + 1
                    KQ(t, 1) = TenFile
                    For j = 1 To Rng.Columns.Count
                        KQ(t, j + 2) = Rng(1, j)
                    Next j
                End If
            wb.Close False
    Next i
    If t Then
        Sh.Range("C6:J" & Lr).ClearContents
        Sh.Range("C6").Resize(t, 6) = KQ
    End If
    Application.ScreenUpdating = True
End Sub