Xin Code lấy dữ liệu theo điều kiện

dinhquang042000 · 17/9/18

Gửi các anh chị FORUM,

em đang tập làm 1 báo cáo bằng VBA, Em muốn tách các giá trị sheet R03_RP001 với các côt
Ves. Opt Vessel Name Departure time ContainerNo Iso Status Imo Oog Category Activity code
thỏa mãn các điều kiện sang sheet VESSEL D:
Điều kiện:
- Thời gian ô C3 Sheet BAO CAO >Thời gian ở cột E (Departure time) > Thời gian ô C2 Sheet BAO CAO
- Giá trị cột K (Category) = "D"
Mong được mọi người chỉ dẫn giúp em ạ

HieuCD · 17/9/18

dinhquang042000 đã viết:
Gửi các anh chị FORUM,

em đang tập làm 1 báo cáo bằng VBA, Em muốn tách các giá trị sheet R03_RP001 với các côt
Ves. Opt Vessel Name Departure time ContainerNo Iso Status Imo Oog Category Activity code
thỏa mãn các điều kiện sang sheet VESSEL D:
Điều kiện:
- Thời gian ô C3 Sheet BAO CAO >Thời gian ở cột E (Departure time) > Thời gian ô C2 Sheet BAO CAO
- Giá trị cột K (Category) = "D"
Mong được mọi người chỉ dẫn giúp em ạ

Mã:

Sub LocTAUND()
  Dim sArr, Res(), colArr As Variant
  Dim i As Long, k As Long, j As Integer
  Dim fDay, eDay, iDay, tmp, ngay
  Dim dk As Boolean
  Const cateString = "D"
  colArr = Array(0, 1, 2, 5, 6, 7, 8, 9, 10, 11, 16)
 
  With Sheets("R03_RP001")
    sArr = .Range("A1:P" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 10)
 
  With Sheets("BAO CAO")
    fDay = .Range("C2").Value
    eDay = .Range("C3").Value
  End With
 
  For i = 1 To UBound(sArr)
    dk = False
    If i = 1 Then
      dk = True
    Else
      tmp = sArr(i, 5)
      ngay = Mid(tmp, 1, 2)
      Mid(tmp, 1, 2) = Mid(tmp, 4, 2)
      Mid(tmp, 4, 2) = ngay
      iDay = CDate(tmp)
      If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
    End If
    If dk Then
        k = k + 1
        For j = 1 To 10
            Res(k, j) = sArr(i, colArr(j))
        Next j
    End If
  Next i
 
  With Sheets("VESSEL D")
    .Range("A1:J" & .Range("A200000").End(xlUp).Row).ClearContents
    If k > 0 Then .Range("A1").Resize(k, 10) = Res
  End With
End Sub

dinhquang042000 · 18/9/18

HieuCD đã viết:

Mã:

Sub LocTAUND()
  Dim sArr, Res(), colArr As Variant
  Dim i As Long, k As Long, j As Integer
  Dim fDay, eDay, iDay, tmp, ngay
  Dim dk As Boolean
  Const cateString = "D"
  colArr = Array(0, 1, 2, 5, 6, 7, 8, 9, 10, 11, 16)

  With Sheets("R03_RP001")
    sArr = .Range("A1:P" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 10)

  With Sheets("BAO CAO")
    fDay = .Range("C2").Value
    eDay = .Range("C3").Value
  End With

  For i = 1 To UBound(sArr)
    dk = False
    If i = 1 Then
      dk = True
    Else
      tmp = sArr(i, 5)
      ngay = Mid(tmp, 1, 2)
      Mid(tmp, 1, 2) = Mid(tmp, 4, 2)
      Mid(tmp, 4, 2) = ngay
      iDay = CDate(tmp)
      If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
    End If
    If dk Then
        k = k + 1
        For j = 1 To 10
            Res(k, j) = sArr(i, colArr(j))
        Next j
    End If
  Next i

  With Sheets("VESSEL D")
    .Range("A1:J" & .Range("A200000").End(xlUp).Row).ClearContents
    If k > 0 Then .Range("A1").Resize(k, 10) = Res
  End With
End Sub

Dạ em cám ơn anh Hiếu nhiều ạ. Em dùng thử thì thấy khi lọc nó vẫn bị sót các giá trị
Như điều kiện của em từ 25/06/2018 tới 25/07/2018 thì bị thiếu các giá trị các ngày từ 04/07/2018 - 12/07/2018.
Mong anh chỉ giáo thêm ạ.
Cho em hỏi thêm chút, Nếu lấy dữ liệu Giá trị cột K (Category) <> "D" thì chỉnh sửa code này thế nào đc ạ.

HieuCD · 18/9/18

dinhquang042000 đã viết:
Dạ em cám ơn anh Hiếu nhiều ạ. Em dùng thử thì thấy khi lọc nó vẫn bị sót các giá trị
Như điều kiện của em từ 25/06/2018 tới 25/07/2018 thì bị thiếu các giá trị các ngày từ 04/07/2018 - 12/07/2018.
Mong anh chỉ giáo thêm ạ.
Cho em hỏi thêm chút, Nếu lấy dữ liệu Giá trị cột K (Category) <> "D" thì chỉnh sửa code này thế nào đc ạ.

Lấy đủ theo ngày nhưng quên chỉnh lại ngày tháng
Thêm bẩy lổi cấu hình ngày tháng và điều kiện ngày ở sheet BaoCao

Mã:

Sub LocTAUND()
  Dim sArr, Res(), colArr As Variant
  Dim i As Long, k As Long, j As Integer
  Dim fDay, eDay, iDay, tmp, ngay As String
  Dim dk As Boolean
  Const cateString = "D"
  colArr = Array(0, 1, 2, 5, 6, 7, 8, 9, 10, 11, 16)
 
  With Sheets("R03_RP001")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A1:P" & i).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 10)
 
  With Sheets("BAO CAO")
    fDay = .Range("C2").Value
    eDay = .Range("C3").Value
    If TypeName(fDay) <> "Date" Or TypeName(eDay) <> "Date" Then MsgBox ("Ngay bao cao sai"): Exit Sub
  End With
 
  For i = 1 To UBound(sArr)
    dk = False
    If i = 1 Then
      dk = True
    Else
      tmp = sArr(i, 5)
      If Day(DateValue("1/5/2018")) = 5 Then
        ngay = Mid(tmp, 1, 2)
        Mid(tmp, 1, 2) = Mid(tmp, 4, 2)
        Mid(tmp, 4, 2) = ngay
      End If
      iDay = CDate(tmp)
      If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
    End If
    If dk Then
      k = k + 1
      For j = 1 To 10
        If j = 3 Then Res(k, j) = iDay Else Res(k, j) = sArr(i, colArr(j))
      Next j
    End If
  Next i
 
  With Sheets("VESSEL D")
    .Range("A1:J" & .Range("A200000").End(xlUp).Row).ClearContents
    If k > 0 Then .Range("A1").Resize(k, 10) = Res
  End With
End Sub

Nếu xét <>"D" thì chỉnh dòng lệnh
If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
thành
If iDay >= fDay And iDay < eDay And sArr(i, 11) <> cateString Then dk = True

Không thích "D" thì chỉnh lệnh: Const cateString = "D"

dinhquang042000 · 18/9/18

HieuCD đã viết:

Lấy đủ theo ngày nhưng quên chỉnh lại ngày tháng
Thêm bẩy lổi cấu hình ngày tháng và điều kiện ngày ở sheet BaoCao

Mã:

Sub LocTAUND()
  Dim sArr, Res(), colArr As Variant
  Dim i As Long, k As Long, j As Integer
  Dim fDay, eDay, iDay, tmp, ngay As String
  Dim dk As Boolean
  Const cateString = "D"
  colArr = Array(0, 1, 2, 5, 6, 7, 8, 9, 10, 11, 16)

  With Sheets("R03_RP001")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A1:P" & i).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 10)

  With Sheets("BAO CAO")
    fDay = .Range("C2").Value
    eDay = .Range("C3").Value
    If TypeName(fDay) <> "Date" Or TypeName(eDay) <> "Date" Then MsgBox ("Ngay bao cao sai"): Exit Sub
  End With

  For i = 1 To UBound(sArr)
    dk = False
    If i = 1 Then
      dk = True
    Else
      tmp = sArr(i, 5)
      If Day(DateValue("1/5/2018")) = 5 Then
        ngay = Mid(tmp, 1, 2)
        Mid(tmp, 1, 2) = Mid(tmp, 4, 2)
        Mid(tmp, 4, 2) = ngay
      End If
      iDay = CDate(tmp)
      If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
    End If
    If dk Then
      k = k + 1
      For j = 1 To 10
        If j = 3 Then Res(k, j) = iDay Else Res(k, j) = sArr(i, colArr(j))
      Next j
    End If
  Next i

  With Sheets("VESSEL D")
    .Range("A1:J" & .Range("A200000").End(xlUp).Row).ClearContents
    If k > 0 Then .Range("A1").Resize(k, 10) = Res
  End With
End Sub

Nếu xét <>"D" thì chỉnh dòng lệnh
If iDay >= fDay And iDay < eDay And sArr(i, 11) = cateString Then dk = True
thành
If iDay >= fDay And iDay < eDay And sArr(i, 11) <> cateString Then dk = True

Không thích "D" thì chỉnh lệnh: Const cateString = "D"

Dạ em cảm ơn anh nhiều nhiều ạ. Code giờ chạy ngon rùi ạ.

Xin Code lấy dữ liệu theo điều kiện

dinhquang042000

Thành viên chính thức

File đính kèm

HieuCD

Chuyên gia GPE

dinhquang042000

Thành viên chính thức

HieuCD

Chuyên gia GPE

File đính kèm

dinhquang042000

Thành viên chính thức

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

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

Đếm ngược thời gian