Hỗ trợ tổng hợp dữ liệu kết quả tìm kiếm theo ngày

Liên hệ QC
D

domjnjc

Thành viên chính thức
Tham gia
7/5/12
Bài viết
86
Được thích
13
Xin chào các anh/chị trong diễn đàn, em có file đính kèm cùng bên dưới, trong đó có sheet result1 và result2, ví dụ em nhập dữ liệu vào phần input (gõ lần lượt từng ô) của sheet result2, sẽ hiện ra kết quả tìm kiếm như trong file, sau đó em muốn tổng hợp dữ liệu đó theo thứ tự ngày vào sheet "conclu" ạ. Mong anh/chị trợ giúp!
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
domjnjc đã viết:
Xin chào các anh/chị trong diễn đàn, em có file đính kèm cùng bên dưới, trong đó có sheet result1 và result2, ví dụ em nhập dữ liệu vào phần input (gõ lần lượt từng ô) của sheet result2, sẽ hiện ra kết quả tìm kiếm như trong file, sau đó em muốn tổng hợp dữ liệu đó theo thứ tự ngày vào sheet "conclu" ạ. Mong anh/chị trợ giúp!
Nhấp chuột vào đây để mở rộng...
Chạy sub
Mã: 
Sub ABC()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
  End With
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          If sArr(i, 2) = dk Then
            If sArr(i, 4) = dk2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
            End If
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy sub
Mã: 
Sub ABC()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
  End With
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          If sArr(i, 2) = dk Then
            If sArr(i, 4) = dk2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
            End If
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
tks a, em chạy sub được rồi ạ!
 
Upvote 0
HieuCD đã viết:
Chạy sub
Mã: 
Sub ABC()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
  End With
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          If sArr(i, 2) = dk Then
            If sArr(i, 4) = dk2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
            End If
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
Có 1 vấn đề phát sinh như sau ạ: khi em tìm kiếm a1,c1: kết quả hiện có thể có cả trường hợp có ngày chứa c1,a1, khi đó sub chỉ cập nhật theo thứ tự tìm kiếm a1,c1 chứ không chứa ngày có c1,a1 ạ
 
Upvote 0
HieuCD đã viết:
Bạn gởi file với ví dụ minh họa
Nhấp chuột vào đây để mở rộng...
Ví dụ: nhập tìm kiếm a3, c3 vào phần input của result2, ta được kết quả như file đính kèm, (tồn tại ngày 11/5 chứa c3 và a3). Khi em chạy sub thì kết quả thu được thiếu ngày 11/5 với kết quả c3,a3 ạ
 

File đính kèm

  • hd.xlsm
    2.9 MB · Đọc: 7
Upvote 0
domjnjc đã viết:
Ví dụ: nhập tìm kiếm a3, c3 vào phần input của result2, ta được kết quả như file đính kèm, (tồn tại ngày 11/5 chứa c3 và a3). Khi em chạy sub thì kết quả thu được thiếu ngày 11/5 với kết quả c3,a3 ạ
Nhấp chuột vào đây để mở rộng...
ý bạn chỉ cần giống điều kiện không cần đúng cột
Mã: 
Sub Button1_Click()
Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, t&, t2&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
    If dk = dk2 Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          t = 0: t2 = 0
          For j = 2 To 5
            If sArr(i, j) = dk Then t = 1
            If sArr(i, j) = dk2 Then t2 = 1
          Next j
          If t + t2 = 2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
 
Upvote 0
HieuCD đã viết:
ý bạn chỉ cần giống điều kiện không cần đúng cột
Mã: 
Sub Button1_Click()
Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, t&, t2&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
    If dk = dk2 Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          t = 0: t2 = 0
          For j = 2 To 5
            If sArr(i, j) = dk Then t = 1
            If sArr(i, j) = dk2 Then t2 = 1
          Next j
          If t + t2 = 2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
Tks anh, bao quát điều kiện r ạ!
 
Upvote 0
HieuCD đã viết:
ý bạn chỉ cần giống điều kiện không cần đúng cột
Mã: 
Sub Button1_Click()
Dim sh As Worksheet, sArr(), Res()
  Dim dk, dk2, sRow&, i&, j&, t&, t2&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result2")
    dk = .Range("A2").Value:   dk2 = .Range("B2").Value
    If dk = Empty Or dk2 = Empty Then Exit Sub
    If dk = dk2 Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          t = 0: t2 = 0
          For j = 2 To 5
            If sArr(i, j) = dk Then t = 1
            If sArr(i, j) = dk2 Then t2 = 1
          Next j
          If t + t2 = 2 Then
              k = k + 1
              For j = 1 To 5
                Res(k, j) = sArr(i, j)
              Next j
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
          End If
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("conclu")
    i = .Range("D" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("D2:H" & i).ClearContents
    If k Then
      .Range("D2").Resize(k).NumberFormat = "@"
      .Range("D2").Resize(k, 6) = Res
      .Range("D2").Resize(k, 6).Sort .Range("I2"), xlAscending, Header:=xlNo
      .Range("I2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
a giúp em tạo thêm 1 button tổng hợp tương tự với kết quả tìm được ở sheet result1 với ạ, e mày mò mà không có ra ạ@@!
 
Lần chỉnh sửa cuối:
Upvote 0
domjnjc đã viết:
tổng hợp kết quả của result1 vào giống như ở sheet conclu ạ
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub Result1()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, sRow&, i&, j&, t&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result1")
    dk = .Range("C2").Value
    If dk = Empty Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          For j = 2 To 5
            If sArr(i, j) = dk Then
              k = k + 1
              For c = 1 To 5
                Res(k, c) = sArr(i, c)
              Next c
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
              Exit For
            End If
          Next j
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("result1")
    i = .Range("AE" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("AE2:AJ" & i).ClearContents
    If k Then
      .Range("AE2").Resize(k).NumberFormat = "@"
      .Range("AE2").Resize(k, 6) = Res
      .Range("AE2").Resize(k, 6).Sort .Range("AJ2"), xlAscending, Header:=xlNo
      .Range("AJ2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub Result1()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, sRow&, i&, j&, t&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result1")
    dk = .Range("C2").Value
    If dk = Empty Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          For j = 2 To 5
            If sArr(i, j) = dk Then
              k = k + 1
              For c = 1 To 5
                Res(k, c) = sArr(i, c)
              Next c
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
              Exit For
            End If
          Next j
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("result1")
    i = .Range("AE" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("AE2:AJ" & i).ClearContents
    If k Then
      .Range("AE2").Resize(k).NumberFormat = "@"
      .Range("AE2").Resize(k, 6) = Res
      .Range("AE2").Resize(k, 6).Sort .Range("AJ2"), xlAscending, Header:=xlNo
      .Range("AJ2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
TKs a, chạy tốt ạ!
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub Result1()
  Dim sh As Worksheet, sArr(), Res()
  Dim dk, sRow&, i&, j&, t&, k&, S
  Dim chk As Boolean, chk2 As Boolean

  With Sheets("result1")
    dk = .Range("C2").Value
    If dk = Empty Then Exit Sub
  End With
 
  ReDim Res(1 To 10000, 1 To 6)
  For Each sh In ActiveWorkbook.Worksheets
    If IsNumeric(sh.Name) Then
      i = sh.Range("E60000").End(xlUp).Row
      If i >= 2 Then
        sArr = sh.Range("A2:E" & i).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          For j = 2 To 5
            If sArr(i, j) = dk Then
              k = k + 1
              For c = 1 To 5
                Res(k, c) = sArr(i, c)
              Next c
              S = Split(sArr(i, 1), "/")
              Res(k, 6) = DateValue("2000/" & S(1) & "/" & S(0))
              Exit For
            End If
          Next j
        Next i
      End If
    End If
  Next sh
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Sheets("result1")
    i = .Range("AE" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("AE2:AJ" & i).ClearContents
    If k Then
      .Range("AE2").Resize(k).NumberFormat = "@"
      .Range("AE2").Resize(k, 6) = Res
      .Range("AE2").Resize(k, 6).Sort .Range("AJ2"), xlAscending, Header:=xlNo
      .Range("AJ2").Resize(k).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
Nhấp chuột vào đây để mở rộng...
Anh cho em hỏi, tại sao sau khi nhập giá trị vào ô input của sheet result1 và cho ra kết quả, ta làm thao tác xóa dữ liệu 1 ngày bất kỳ rồi chạy sub, thì vẫn cho ra được kết quả của ngày đã xóa ạ?
 
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

Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
24
Đọc
455
SA_DQ
SA_DQ
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
82
batista911
B
C
Chia sẻ: Kết quả xổ số Keno
    • Thích
Trả lời
4
Đọc
155
Tuấn Bụng Bự
Tuấn Bụng Bự
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
12
Đọc
210
ptm0412
ptm0412
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
67
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
130
kimtanmap
kimtanmap
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
2
Đọc
36
nguyenphuochien166
nguyenphuochien166
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
67
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
36
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
121
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
109
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
153
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
288
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
18
Đọc
20K
DeTong
D
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
298
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
278
ptm0412
ptm0412
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
62
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
196
GPE-Trợ Lý
GPE-Trợ Lý
Xem thêm…

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