Trích xuất dữ liệu nhiều sheet

Liên hệ QC
V

vulunktheky

Thành viên thường trực
Tham gia
2/3/18
Bài viết
268
Được thích
84
Giới tính
Nam
Chào anh/chị, Em xin mô tả lại file của em như sau, Phiền anh chị hỗ trợ.
'+ Liệt kê tất cả các NGUYÊN NHÂN PHẾ theo NGÀY/ CA/ ID HÌNH THỂ ở sheet 1QA (từ G4 đên T4):
Lưu Ý: Là trích xuất những nguyên nhân có dữ liệu số đôi phế.
1666060312595.png
+ PHÂN LOẠI ĐẾ: Dựa vào ID Hình thể để dò tìm ở sheet 2DATA để lấy dữ liệu cột A
+ TÊN HÌNH THỂ: Dựa vào ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột C
+ MÃ MCS: Dựa vào ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột E
+ NHIỀU MẪ MCS: ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột F
+ MÀU ĐẾ PHẾ /MẪ : ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột G
+ SỐ ĐÔI PHẾ: Dựa vào ID Hình thể/ Ca/ Ngày/ Nguyên nhân phế để tính tổng số phế ở sheet 1QA (Vùng tính tổng từ G5:T), sau đó chia 2
=> mình có sheet kết quả mẫu để anh chị dễ hình dung ạ. Xin cảm ơn anh chị đã giúp đỡ.
 

File đính kèm

  • CROSS _GPE.xlsb
    30 KB · Đọc: 8
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vulunktheky đã viết:
Chào anh/chị, Em xin mô tả lại file của em như sau, Phiền anh chị hỗ trợ.
'+ Liệt kê tất cả các NGUYÊN NHÂN PHẾ theo NGÀY/ CA/ ID HÌNH THỂ ở sheet 1QA (từ G4 đên T4):
Lưu Ý: Là trích xuất những nguyên nhân có dữ liệu số đôi phế.
View attachment 282263
+ PHÂN LOẠI ĐẾ: Dựa vào ID Hình thể để dò tìm ở sheet 2DATA để lấy dữ liệu cột A
+ TÊN HÌNH THỂ: Dựa vào ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột C
+ MÃ MCS: Dựa vào ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột E
+ NHIỀU MẪ MCS: ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột F
+ MÀU ĐẾ PHẾ /MẪ : ID hình thể dò tìm ở sheet 2DATA để lấy dữ liệu cột G
+ SỐ ĐÔI PHẾ: Dựa vào ID Hình thể/ Ca/ Ngày/ Nguyên nhân phế để tính tổng số phế ở sheet 1QA (Vùng tính tổng từ G5:T), sau đó chia 2
=> mình có sheet kết quả mẫu để anh chị dễ hình dung ạ. Xin cảm ơn anh chị đã giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Bạn thử code dưới xem được không nhé!
PHP: 
Sub GPE()
    Dim Arr(), Res(1 To 10000, 1 To 12), i As Long, j As Long, K As Long
    Dim Lr1 As Long, Lr2 As Long, Arr2 As Range, Rng As Range
    On Error Resume Next
    With Sheets("2DATA")
        Lr2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set Arr2 = .Range("A1:G" & Lr2)
        Set Rng = .Range("D1:D" & Lr2)
    End With
    With Sheets("1QA")
        Lr1 = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A4:T" & Lr1).Value
        For j = 7 To 20
            For i = 2 To UBound(Arr)
                If Arr(i, j) <> "" Then
                    K = K + 1
                    Res(K, 1) = Arr(i, 1): Res(K, 3) = Arr(i, 2)
                    With Application
                        Res(K, 4) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 1)
                        Res(K, 6) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 3)
                        Res(K, 9) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 5)
                        Res(K, 10) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 6)
                        Res(K, 11) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 7)
                    End With
                        Res(K, 5) = Arr(1, j)
                        Res(K, 7) = Arr(i, 4)
                        Res(K, 12) = Arr(i, j) / 2
                End If
            Next i
        Next j
    End With
    Sheets("SUMMARY").Range("E2:P10000").ClearContents
    Sheets("SUMMARY").Range("E2").Resize(K, 12).Value = Res
    '__________________________________________________________________________________
    Dim Dic As Object, Key As String, s As Long
    Dim Lrl As Long, Arrl(), Resl(1 To 100, 1 To 12)
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("SUMMARY")
        Lrl = .Range("E" & Rows.Count).End(xlUp).Row
        Arrl = .Range("E2:P" & Lrl).Value
        For i = 1 To UBound(Arrl)
            Key = Arrl(i, 1) & "|" & Arrl(i, 3) & "|" & Arrl(i, 5) & "|" & Arrl(i, 7)
            If Not Dic.exists(Key) Then
                s = s + 1
                Dic.Add (Key), s
                For j = 1 To 12
                    Resl(s, j) = Arrl(i, j)
                Next j
            Else
                Resl(Dic.Item(Key), 12) = Resl(Dic.Item(Key), 12) + Arrl(i, 12)
            End If
        Next i
        .Range("E2:P1000").ClearContents
        .Range("E2").Resize(s, 12).Value = Resl
        With Range("E1:P1000")
            .Sort .Cells(1, 1), 1, Header:=xlGuess
        End With
    End With
    Set Dic = Nothing
    MsgBox "Hoàn Thành"
End Sub
 

File đính kèm

  • CROSS _GPE.xlsb
    41.6 KB · Đọc: 4
Upvote 0
Xài đỡ:
Mã: 
Option Explicit
Sub TEST()
Dim lr&, i&, j&, k&, rng, arr(), id As String, s
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("1QA")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A4:T" & lr).Value2
    For i = 2 To UBound(rng)
        For j = 7 To UBound(rng, 2)
            id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 4) & "|" & rng(1, j)
            If rng(i, j) > 0 Then
                If Not dic.exists(id) Then
                    dic.Add id, rng(i, j) / 2
                Else
                    dic(id) = dic(id) + rng(i, j) / 2
                End If
            End If
        Next
    Next
End With
With Sheets("2DATA")
    lr = .Cells(Rows.Count, "D").End(xlUp).Row
    rng = .Range("A2:G" & lr).Value
End With
ReDim arr(1 To dic.Count, 1 To 12)
For Each key In dic.keys
    s = Split(key, "|")
    k = k + 1
    arr(k, 1) = s(0): arr(k, 3) = s(1): arr(k, 5) = s(3): arr(k, 7) = s(2)
    For i = 1 To UBound(rng)
        If s(2) = rng(i, 4) Then
            arr(k, 4) = rng(i, 1): arr(k, 6) = rng(i, 3): arr(k, 4) = rng(i, 1)
            arr(k, 9) = rng(i, 1): arr(k, 10) = rng(i, 6): arr(k, 11) = rng(i, 7)
            arr(k, 12) = dic(key)
        End If
    Next
Next
With Sheets("SUMMARY")
    .Range("E2:P10000").ClearContents
    .Range("E2").Resize(k, 12).Value = arr
    .Range("A2:P" & k + 1).Sort .Range("E1"), , .Range("I1")
End With
End Sub
 

File đính kèm

  • CROSS _GPE.xlsb
    92.1 KB · Đọc: 8
Upvote 0
Bienhoa84 đã viết:
Bạn thử code dưới xem được không nhé!
PHP: 
Sub GPE()
    Dim Arr(), Res(1 To 10000, 1 To 12), i As Long, j As Long, K As Long
    Dim Lr1 As Long, Lr2 As Long, Arr2 As Range, Rng As Range
    On Error Resume Next
    With Sheets("2DATA")
        Lr2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set Arr2 = .Range("A1:G" & Lr2)
        Set Rng = .Range("D1:D" & Lr2)
    End With
    With Sheets("1QA")
        Lr1 = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A4:T" & Lr1).Value
        For j = 7 To 20
            For i = 2 To UBound(Arr)
                If Arr(i, j) <> "" Then
                    K = K + 1
                    Res(K, 1) = Arr(i, 1): Res(K, 3) = Arr(i, 2)
                    With Application
                        Res(K, 4) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 1)
                        Res(K, 6) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 3)
                        Res(K, 9) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 5)
                        Res(K, 10) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 6)
                        Res(K, 11) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 7)
                    End With
                        Res(K, 5) = Arr(1, j)
                        Res(K, 7) = Arr(i, 4)
                        Res(K, 12) = Arr(i, j) / 2
                End If
            Next i
        Next j
    End With
    Sheets("SUMMARY").Range("E2:P10000").ClearContents
    Sheets("SUMMARY").Range("E2").Resize(K, 12).Value = Res
    '__________________________________________________________________________________
    Dim Dic As Object, Key As String, s As Long
    Dim Lrl As Long, Arrl(), Resl(1 To 100, 1 To 12)
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("SUMMARY")
        Lrl = .Range("E" & Rows.Count).End(xlUp).Row
        Arrl = .Range("E2:P" & Lrl).Value
        For i = 1 To UBound(Arrl)
            Key = Arrl(i, 1) & "|" & Arrl(i, 3) & "|" & Arrl(i, 5) & "|" & Arrl(i, 7)
            If Not Dic.exists(Key) Then
                s = s + 1
                Dic.Add (Key), s
                For j = 1 To 12
                    Resl(s, j) = Arrl(i, j)
                Next j
            Else
                Resl(Dic.Item(Key), 12) = Resl(Dic.Item(Key), 12) + Arrl(i, 12)
            End If
        Next i
        .Range("E2:P1000").ClearContents
        .Range("E2").Resize(s, 12).Value = Resl
        With Range("E1:P1000")
            .Sort .Cells(1, 1), 1, Header:=xlGuess
        End With
    End With
    Set Dic = Nothing
    MsgBox "Hoàn Thành"
End Sub
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn nhiều, mình sẽ chạy thử với dữ liệu thật
Bài đã được tự động gộp:

bebo021999 đã viết:
Xài đỡ:
Mã: 
Option Explicit
Sub TEST()
Dim lr&, i&, j&, k&, rng, arr(), id As String, s
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("1QA")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A4:T" & lr).Value2
    For i = 2 To UBound(rng)
        For j = 7 To UBound(rng, 2)
            id = rng(i, 1) & "|" & rng(i, 2) & "|" & rng(i, 4) & "|" & rng(1, j)
            If rng(i, j) > 0 Then
                If Not dic.exists(id) Then
                    dic.Add id, rng(i, j) / 2
                Else
                    dic(id) = dic(id) + rng(i, j) / 2
                End If
            End If
        Next
    Next
End With
With Sheets("2DATA")
    lr = .Cells(Rows.Count, "D").End(xlUp).Row
    rng = .Range("A2:G" & lr).Value
End With
ReDim arr(1 To dic.Count, 1 To 12)
For Each key In dic.keys
    s = Split(key, "|")
    k = k + 1
    arr(k, 1) = s(0): arr(k, 3) = s(1): arr(k, 5) = s(3): arr(k, 7) = s(2)
    For i = 1 To UBound(rng)
        If s(2) = rng(i, 4) Then
            arr(k, 4) = rng(i, 1): arr(k, 6) = rng(i, 3): arr(k, 4) = rng(i, 1)
            arr(k, 9) = rng(i, 1): arr(k, 10) = rng(i, 6): arr(k, 11) = rng(i, 7)
            arr(k, 12) = dic(key)
        End If
    Next
Next
With Sheets("SUMMARY")
    .Range("E2:P10000").ClearContents
    .Range("E2").Resize(k, 12).Value = arr
    .Range("A2:P" & k + 1).Sort .Range("E1"), , .Range("I1")
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh nhiều, mình sẽ chạy thử với dữ liệu thật
 
Upvote 0
Bienhoa84 đã viết:
Bạn thử code dưới xem được không nhé!
PHP: 
Sub GPE()
    Dim Arr(), Res(1 To 10000, 1 To 12), i As Long, j As Long, K As Long
    Dim Lr1 As Long, Lr2 As Long, Arr2 As Range, Rng As Range
    On Error Resume Next
    With Sheets("2DATA")
        Lr2 = .Range("A" & Rows.Count).End(xlUp).Row
        Set Arr2 = .Range("A1:G" & Lr2)
        Set Rng = .Range("D1:D" & Lr2)
    End With
    With Sheets("1QA")
        Lr1 = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A4:T" & Lr1).Value
        For j = 7 To 20
            For i = 2 To UBound(Arr)
                If Arr(i, j) <> "" Then
                    K = K + 1
                    Res(K, 1) = Arr(i, 1): Res(K, 3) = Arr(i, 2)
                    With Application
                        Res(K, 4) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 1)
                        Res(K, 6) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 3)
                        Res(K, 9) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 5)
                        Res(K, 10) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 6)
                        Res(K, 11) = .Index(Arr2, .Match(Arr(i, 4), Rng, False), 7)
                    End With
                        Res(K, 5) = Arr(1, j)
                        Res(K, 7) = Arr(i, 4)
                        Res(K, 12) = Arr(i, j) / 2
                End If
            Next i
        Next j
    End With
    Sheets("SUMMARY").Range("E2:P10000").ClearContents
    Sheets("SUMMARY").Range("E2").Resize(K, 12).Value = Res
    '__________________________________________________________________________________
    Dim Dic As Object, Key As String, s As Long
    Dim Lrl As Long, Arrl(), Resl(1 To 100, 1 To 12)
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("SUMMARY")
        Lrl = .Range("E" & Rows.Count).End(xlUp).Row
        Arrl = .Range("E2:P" & Lrl).Value
        For i = 1 To UBound(Arrl)
            Key = Arrl(i, 1) & "|" & Arrl(i, 3) & "|" & Arrl(i, 5) & "|" & Arrl(i, 7)
            If Not Dic.exists(Key) Then
                s = s + 1
                Dic.Add (Key), s
                For j = 1 To 12
                    Resl(s, j) = Arrl(i, j)
                Next j
            Else
                Resl(Dic.Item(Key), 12) = Resl(Dic.Item(Key), 12) + Arrl(i, 12)
            End If
        Next i
        .Range("E2:P1000").ClearContents
        .Range("E2").Resize(s, 12).Value = Resl
        With Range("E1:P1000")
            .Sort .Cells(1, 1), 1, Header:=xlGuess
        End With
    End With
    Set Dic = Nothing
    MsgBox "Hoàn Thành"
End Sub
Nhấp chuột vào đây để mở rộng...

Bienhoa84 đã viết:
Bạn có thể dùng code này
PHP: 
Sub GPE()
    Dim Arr(), Res(), i As Long, j As Long, k As Long, Ws As Worksheet
    Dim Lr As Long, l As Long, m As Long, Res1(), Res2()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If Ws.Name <> "Sheet1" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("Sheet1")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B3:G" & Lr).Value
        ReDim Res(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res1(1 To UBound(Arr, 1) * 5, 1 To 2)
        ReDim Res2(1 To UBound(Arr, 1) * 5, 1 To 2)
        For i = 2 To UBound(Arr, 1)
            For j = 2 To UBound(Arr, 2)
                If UCase(Arr(i, j)) = "GI" & ChrW(7886) & "I" Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "KHﾁ" Then
                    l = l + 1
                    Res1(l, 1) = Arr(i, 1)
                    Res1(l, 2) = Arr(1, j)
                ElseIf UCase(Arr(i, j)) = "TRUNG BﾌNH" Then
                    m = m + 1
                    Res2(m, 1) = Arr(i, 1)
                    Res2(m, 2) = Arr(1, j)
               
                End If
            Next j
        Next i
        If k Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "GI" & ChrW(7886) & "I"
            ActiveSheet.Range("B2").Resize(k, 2).Value = Res
        End If
        If l Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "KHﾁ"
            ActiveSheet.Range("B2").Resize(l, 2).Value = Res1
        End If
        If m Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "TRUNG BﾌNH"
            ActiveSheet.Range("B2").Resize(m, 2).Value = Res2
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Ho瀟 th瀟h"
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bác nhiều đã giúp đỡ các ae gà mới tụi em ah
 
Upvote 0
eagle12 đã viết:
Cám ơn bác nhiều đã giúp đỡ các ae gà mới tụi em ah
Nhấp chuột vào đây để mở rộng...
Bạn lưu ý: ở diễn đàn này không nên viết tắt, dùng từ ngữ tường minh khi trao đổi thì chắc sẽ nhận được sự giúp đỡ từ các thành viên nhiều kinh nghiệm.
—>tôi cũng là thành viên mới như bạn thôi. Trên này có rất nhiều người giỏi và rất nhiệt tình.
 
Upvote 0
Bienhoa84 đã viết:
Bạn lưu ý: ở diễn đàn này không nên viết tắt, dùng từ ngữ tường minh khi trao đổi thì chắc sẽ nhận được sự giúp đỡ từ các thành viên nhiều kinh nghiệm.
—>tôi cũng là thành viên mới như bạn thôi. Trên này có rất nhiều người giỏi và rất nhiệt tình.
Nhấp chuột vào đây để mở rộng...
Vâng ah, em cám ơn bác
 
Upvote 0
eagle12 đã viết:
Vâng ah, em cám ơn bác
Nhấp chuột vào đây để mở rộng...
Ca này khó nha!
Chuyện xưa có người khách đến làm việc tại xã, khi gặp chủ tịch xã, có phàn nàn về việc trẻ em vùng này hay chửi thề quá, ông chủ tịch xã nói:
"Đấy đồng chí xem, dạy bảo mãi mà chúng nó đ. chịu nghe lời!"
 

File đính kèm

  • Capture.JPG
    Capture.JPG
    23.4 KB · Đọc: 10
Upvote 0
bebo021999 đã viết:
Ca này khó nha!
Chuyện xưa có người khách đến làm việc tại xã, khi gặp chủ tịch xã, có phàn nàn về việc trẻ em vùng này hay chửi thề quá, ông chủ tịch xã nói:
"Đấy đồng chí xem, dạy bảo mãi mà chúng nó đ. chịu nghe lời!"
Nhấp chuột vào đây để mở rộng...
Tôi hay gõ kiểu vâng à = vâng ah = vâng ạ, cái này .. giờ chú hiểu chưa .. chưa hiểu thì tôi cũng đ. cần nói với chú
Nghĩ mình cửa trên sao ??
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
28
Đọc
218
LuuAnh980
LuuAnh980
trantrimmo
Xin code VBA xuất pdf từ 3 sheet theo lấy thông tin theo tên sheet ạ.
Trả lời
1
Đọc
91
dangvandang
dangvandang
B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
6
Đọc
104
HieuCD
H
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
6
Đọc
145
Hoàng Tuấn 868
H
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
0
Đọc
78
shnhatha221108
S
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom