Lấy dữ liệu trong một ô ở nhiều sheet và từ nhiều file.

Liên hệ QC

le ngoc lam

Thành viên mới
Tham gia
6/10/17
Bài viết
2
Được thích
0
Giới tính
Nam
Chào các anh chị trong diễn đàn.

Mình là menber mới, mong mọi người chỉ bảo nhiều.
Hiện tại mình có một vấn đề như sau:

- Mình đang muốn dùng VBA để tổng hợp thông tin từ các ô trong nhiều sheet và từ nhiều file khác nhau.
Nhưng vấn đề là ô cần lấy thông tin có chứa hàm (ví dụ là hàm Sum ).

Mong mọi người hỗ trợ.

Cảm ơn tất cả anh chị trên diễn đàn.
Chúc mọi người sức khỏe và làm việc tốt.
 
Ngày trước mình có làm 1 file như này, copy dữ liệu ở các ô khác nhau vào file tổng hợp mà ko cần mở file
 

File đính kèm

  • Copy data.xlsm
    75.2 KB · Đọc: 25
Upvote 0
Ngày trước mình có làm 1 file như này, copy dữ liệu ở các ô khác nhau vào file tổng hợp mà ko cần mở file
Cảm ơn bạn rất nhiều.
Nhưng mình không vào xem được lênh Vb bạn viết.
Excel báo cần pass. Bạn vui lòng cho mình xin pass được không?

Rất mong nhận được sự giúp đỡ
 
Upvote 0
Bạn xem code làm gì?
Tập tin cụ thể của người ta, người ta làm những cái người ta cần. Để bạn dùng được thì bạn phải sửa rất nhiều. Nếu bạn đã hỏi về vấn đề này thì tôi e rằng sức bạn không tự sửa code được đâu. Có xem code thì cũng chả giúp được gì. Tôi e rằng như thế.
Còn nếu bạn tự tin thì code cho nút "Copy dữ liệu" là

Mã:
Sub LayDL_ADO()
Dim i, j, k, irow As Long, irow1, pg As Long
Dim p1, p2, p3 As Long
Dim t As String
Dim text As String
Dim lsSQL As String, Cnn As Object, lrs As Object
ActiveSheet.Unprotect "123"
Sheet1.Range("A3:A1000").Interior.Color = xlNone
ActiveSheet.Protect "123", DrawingObjects:=False, Contents:=True, Scenarios:=False
On Error Resume Next
For i = 3 To Sheet1.Range("A65536").End(xlUp).Row
If Sheet1.Range("E" & i) <> "" Then
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & Sheet1.Range("A" & i) & _
                        ";Extended Properties=""Excel 8.0;HDR=No;"";"
    .Open
End With
    lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A1:AH50] "
    lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
   .[A1:AH50].ClearContents
   .[A1].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 2
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & Sheet1.Range("A" & i) & _
                        ";Extended Properties=""Excel 8.0;HDR=No;"";"
    .Open
End With
    lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A55:AH65] "
    lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
   .[A55:A65].ClearContents
   .[A55].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 3
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & Sheet1.Range("A" & i) & _
                        ";Extended Properties=""Excel 8.0;HDR=No;"";"
    .Open
End With
    lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A66:AH75] "
    lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
   .[A66:A75].ClearContents
   .[A66].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
'*********************************** copy part 4
Set Cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")
With Cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & Sheet1.Range("A" & i) & _
                        ";Extended Properties=""Excel 8.0;HDR=No;"";"
    .Open
End With
    lsSQL = "SELECT * " & "FROM [" & Sheet1.Range("C1") & "$A120:AH50000] "
    lrs.Open lsSQL, Cnn, 3, 1
With Sheet3
   .[A120:AH50000].ClearContents
   .[A120].CopyFromRecordset lrs
End With
lrs.Close: Set lrs = Nothing
Cnn.Close: Set Cnn = Nothing
irow1 = Sheet3.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
If irow1 < 149 Then
ActiveSheet.Unprotect "123"
text = "Ba5n ca62n xem la5i to72 khai ha3i quan o73 do2ng so61 " & i
  With CreateObject("WScript.Shell")
    .Popup UniConvert(text, "VNI"), , "THÔNG BÁO", vbOKOnly
  End With
  Sheet1.Range("A" & i).Interior.Color = 65535
ActiveSheet.Protect "123", DrawingObjects:=False, Contents:=True, Scenarios:=False
'Informm.thongbao1
'Exit Sub
End If
pg = (irow1 + 22 - 150) / 75
For k = 1 To pg
irow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For j = 18 To Sheet1.Range("H2") + 3
If Sheet1.Range("H" & j) = "" Then
Sheet2.Range(Sheet1.Range("J" & j) & irow) = Sheet3.Range(Sheet1.Range("I" & j))
Else
Sheet2.Range(Sheet1.Range("J" & j) & irow) = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & j), Sheet1.Range("I" & j))
End If
Next
Sheet2.Range(Sheet1.Range("J17") & irow) = Left(Sheet3.Range(Sheet1.Range("I17")), 10) ' Ngay dk
Sheet2.Range(Sheet1.Range("J4") & irow) = Left(Sheet3.Range(Sheet1.Range("I4")), 3)  ' Loai hinh
Sheet2.Range(Sheet1.Range("J5") & irow) = Right(Sheet3.Range(Sheet1.Range("I5")), Len(Sheet3.Range(Sheet1.Range("I5"))) - 4) 'So invoice
Sheet2.Range(Sheet1.Range("J6") & irow) = remmm(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H6"), Sheet1.Range("I6"))) ' So TT
Sheet2.Range(Sheet1.Range("J11") & irow) = remd(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H11"), Sheet1.Range("I11"))) ' So luong
Sheet2.Range(Sheet1.Range("J13") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H13"), Sheet1.Range("I13"))) ' Tri gia hoa don
Sheet2.Range(Sheet1.Range("J15") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H15"), Sheet1.Range("I15"))) ' Tien thue nhap khau
Sheet2.Range(Sheet1.Range("J12") & irow) = chgd(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H12"), Sheet1.Range("I12"))) ' Don gia
Sheet2.Range(Sheet1.Range("J14") & irow) = remm(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H14"), Sheet1.Range("I14"))) ' Thue XNK %

If Sheet3.Range("H178") = Sheet1.Range("H16") Then
Sheet2.Range(Sheet1.Range("J16") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(36, Sheet1.Range("I16")))
Sheet2.Range(Sheet1.Range("J33") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(31, Sheet1.Range("I16")))
Else:
Sheet2.Range(Sheet1.Range("J16") & irow) = chg(Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(31, Sheet1.Range("I16")))
End If ' Tien thue VAT & thue CBPG


If Left(Sheet3.Range(Sheet1.Range("I4")), 3) = "E31" Then  'A12 7 E31
t = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & 7), Sheet1.Range("I" & 7))
p1 = Application.WorksheetFunction.Find(":", t)
p2 = Application.WorksheetFunction.Find("x", LCase(t))
p3 = Application.WorksheetFunction.Find("#&", t)
Sheet2.Range(Sheet1.Range("J7") & irow) = Left(t, p3 - 1) 'Mă NPL / SP
Sheet2.Range(Sheet1.Range("J8") & irow) = LCase(Mid(t, p1 + 1, p2 - p1 - 1)) 'Thickness
Sheet2.Range(Sheet1.Range("J9") & irow) = LCase(Mid(t, p2 + 1, Len(t) - p2))  'Width
Sheet2.Range(Sheet1.Range("J10") & irow) = Right(t, Len(t) - p3 - 1)  'Ten hang
Else
t = Sheet3.Range("C" & (150 + (k - 1) * 75)).Offset(Sheet1.Range("H" & 7), Sheet1.Range("I" & 7))
p1 = Application.WorksheetFunction.Find(":", t)
p2 = Application.WorksheetFunction.Find("x", LCase(t))
Sheet2.Range(Sheet1.Range("J8") & irow) = LCase(Mid(t, p1 + 1, p2 - p1 - 1)) 'Thickness
Sheet2.Range(Sheet1.Range("J9") & irow) = LCase(Mid(t, p2 + 1, Len(t) - p2))  'Width
Sheet2.Range(Sheet1.Range("J10") & irow) = t  'Ten hang
End If
Next
End If
Next
End Sub
 
Upvote 0
Pass của tất cả các file tôi để trên diễn đàn (nếu có để pass) đều là "anh2depjai" hoặc "Anh2depjai"

Bạn có thể bung ra và ngâm cứu nhé.
 
Upvote 0
Web KT
Back
Top Bottom