Nhờ chỉnh sửa công thức: tìm và sắp xếp dữ liệu theo thời gian (3 người xem)

Ba Tê · 21/10/18

laivanyen8 đã viết:
@Ba Tê
Vâng cảm ơn Thầy. Thầy có thể giúp em thêm 1 trường hợp nữa là các ngày trùng nhau ưu tiên lấy dữ liệu trên xuống dưới, sau đó mới từ trái sang phải được không ạ, hiện code Thầy vừa viết đang ưu tiên cho các ngày trùng nhau lấy từ trái sang phải, sau trên xuống dưới ! Em cần cả 2 ạ
Và vùng dữ liệu từ cột thầy đưa luôn vào code giúp em với ạ, ví dụ từ cột C:H em sẽ chủ động thay đổi vùng đó ạ

Chủ động thay đổi vùng sao bằng chọn vùng trực tiếp?
Muốn cả hai trường hợp sao biết lúc nào muốn gì, cho 2 nút của 2 trường hợp luôn.

HieuCD · 21/10/18

laivanyen8 đã viết:
@HieuCD
Em cảm ơn anh nhưng em test thử thì Code lấy dữ liệu cho code B những ngày trùng nhau thì không được theo quy luật ưu tiên nào ạ, anh xem lại giúp em; em muốn lấy theo thứ tự không theo Alpha B của chữ cái mà ưu tiên th1: từ trên xuống dưới và th2: trái qua phải. Và vùng dữ liệu em cũng muốn đưa luôn vào code, em sẽ chủ động thay đổi vùng đó trong code ạ

Thu code

Mã:

Sub XepThuTu()
  Dim Rng As Range
  Dim j As Long, sRow As Long, sCol As Long, fRow As Long, eRow As Long
  Set Rng = Sheets("Sheet1").Range("A2:H10")
  sCol = Int(Rng.Columns.Count / 2) * 2
  If sCol < 2 Then MsgBox ("Vùng du lieu phai >= 2 cot"):     Exit Sub
  sRow = Rng.Rows.Count
  With Sheets("Sheet2")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:B" & eRow).ClearContents
    For j = 1 To sCol Step 2
      eRow = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A" & eRow + 1).Resize(sRow, 2) = Rng.Cells(1, j).Resize(sRow, 2).Value
    Next j
    eRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A2:B" & eRow).Sort .Range("A2"), 1, Header:=xlNo
  End With
End Sub

huonglien1901 · 21/10/18

HieuCD đã viết:

Thu code

Mã:

Sub XepThuTu()
  Dim Rng As Range
  Dim j As Long, sRow As Long, sCol As Long, fRow As Long, eRow As Long
  Set Rng = Sheets("Sheet1").Range("A2:H10")
  sCol = Int(Rng.Columns.Count / 2) * 2
  If sCol < 2 Then MsgBox ("Vùng du lieu phai >= 2 cot"):     Exit Sub
  sRow = Rng.Rows.Count
  With Sheets("Sheet2")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:B" & eRow).ClearContents
    For j = 1 To sCol Step 2
      eRow = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A" & eRow + 1).Resize(sRow, 2) = Rng.Cells(1, j).Resize(sRow, 2).Value
    Next j
    eRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A2:B" & eRow).Sort .Range("A2"), 1, Header:=xlNo
  End With
End Sub

Anh Hiếu có thể giải thích giải thuật dòng code này được không?

YenLV · 21/10/18

@Ba Tê
Vâng em cảm ơn Thầy làm cả 2 trường hợp về thứ tự ưu tiên lựa chọn khi trùng nhau như vậy đạt ý nguyện của em rồi, giờ em muốn thêm một chút "Chủ động thay đổi vùng sao bằng chọn vùng trực tiếp?" nghĩa là bổ sung đoạn code chọn vùng như trong đoạn code của anh HieuCd
Set Rng = Sheets("Sheet1").Range("A2:H100"). Vùng A2H100 là vùng em có thể thay đổi đối với mỗi dự án sẽ cố định phần này, không phải quét lại vùng mỗi khi chạy lại VBA khi có thay đổi dữ liệu đầu vào ạ.

Bài đã được tự động gộp: 21/10/18

@HieuCD
yeah.Cảm ơn anh ! anh giúp em thêm trường hợp ưu tiên trái sang phải trước, rồi mới đến trên xuống dưới. Code anh vừa viết với trường hợp ưu tiên trên xuống dưới, trái qua phải như vậy em thấy ok rồi ạ

Ba Tê · 21/10/18

laivanyen8 đã viết:
Vâng em cảm ơn Thầy làm cả 2 trường hợp về thứ tự ưu tiên lựa chọn khi trùng nhau như vậy đạt ý nguyện của em rồi, giờ em muốn thêm một chút "Chủ động thay đổi vùng sao bằng chọn vùng trực tiếp?" nghĩa là bổ sung đoạn code chọn vùng như trong đoạn code của anh HieuCd
Set Rng = Sheets("Sheet1").Range("A2:H100"). Vùng A2H100 là vùng em có thể thay đổi đối với mỗi dự án sẽ cố định phần này, không phải quét lại vùng mỗi khi chạy lại VBA khi có thay đổi dữ liệu đầu vào ạ.

File bài #21.
Thay 2 cái Sub cũ thành 2 cái này rồi tùy chỉnh vùng chọn theo ý muốn.

PHP:

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, Col As Long
sArr = Sheet1.Range("C2:H10000").Value '-------Thay doi vung chon tuy y'
R = UBound(sArr)
Col = UBound(sArr, 2)
ReDim dArr(1 To R * Col, 1 To 2)
For I = 1 To R
    For J = 1 To Col Step 2
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, J)
            If J + 1 <= Col Then dArr(K, 2) = sArr(I, J + 1)
        End If
    Next J
Next I
With Sheets("GPE")
    .Select
    .Range("B2").Resize(100000, 2).ClearContents
    .Range("B2").Resize(K, 2) = dArr
    .Range("B2").Resize(K, 2).Sort Key1:=Range("B2"), Order1:=xlAscending
End With
End Sub
Public Sub sGpe2()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, Col As Long
sArr = Sheet1.Range("C2:H10000").Value '-------Thay doi vung chon tuy y'
R = UBound(sArr)
Col = UBound(sArr, 2)
ReDim dArr(1 To R * Col, 1 To 2)
For J = 1 To Col Step 2
    For I = 1 To R
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, J)
            If J + 1 <= Col Then dArr(K, 2) = sArr(I, J + 1)
        End If
    Next I
Next J
With Sheets("GPE")
    .Select
    .Range("B2").Resize(100000, 2).ClearContents
    .Range("B2").Resize(K, 2) = dArr
    .Range("B2").Resize(K, 2).Sort Key1:=Range("B2"), Order1:=xlAscending
End With
End Sub

HieuCD · 24/10/18

laivanyen8 đã viết:
@Ba Tê
Vâng em cảm ơn Thầy làm cả 2 trường hợp về thứ tự ưu tiên lựa chọn khi trùng nhau như vậy đạt ý nguyện của em rồi, giờ em muốn thêm một chút "Chủ động thay đổi vùng sao bằng chọn vùng trực tiếp?" nghĩa là bổ sung đoạn code chọn vùng như trong đoạn code của anh HieuCd
Set Rng = Sheets("Sheet1").Range("A2:H100"). Vùng A2H100 là vùng em có thể thay đổi đối với mỗi dự án sẽ cố định phần này, không phải quét lại vùng mỗi khi chạy lại VBA khi có thay đổi dữ liệu đầu vào ạ.

Bài đã được tự động gộp: 21/10/18

@HieuCD
yeah.Cảm ơn anh ! anh giúp em thêm trường hợp ưu tiên trái sang phải trước, rồi mới đến trên xuống dưới. Code anh vừa viết với trường hợp ưu tiên trên xuống dưới, trái qua phải như vậy em thấy ok rồi ạ

Chạy code, chọn cách sort

Mã:

Sub XepThuTu()
  Dim sArr(), tArr(), Res(), S
  Dim i As Long, k As Long, sRow As Long, j As Byte, sCol As Byte
  Dim t, tMin As Long, tMax As Long
  Dim Msb, Style, Title
  Const VungChon As String = "A2:H10"
 
  With Sheets("Sheet1")
    sArr = .Range(VungChon).Value
    tMin = Application.Min(.Range(VungChon))
    tMax = Application.Max(.Range(VungChon))
  End With
  sCol = Int(UBound(sArr, 2) / 2) * 2
  If sCol < 2 Then MsgBox ("Vùng du lieu phai >= 2 cot"):     Exit Sub
  sRow = UBound(sArr)
  ReDim tArr(tMin To tMax)
  ReDim Res(1 To sRow * sCol / 2, 1 To 2)
 
  Msg = "Yes:   Sort List from Up to Down" & Chr(10) & Chr(10) & "No:   Sort List from Left to Right"
  Style = vbYesNo + vbDefaultButton1
  Title = "Do you want Sort Lists Up to Down ?"
  Response = MsgBox(Msg, Style, Title)
  If Response = vbYes Then    ' User chose Yes.
    For j = 1 To sCol Step 2
      For i = 1 To sRow
        t = CLng(sArr(i, j))
        If t > 0 Then tArr(t) = tArr(t) & "," & sArr(i, j + 1)
      Next i
    Next j
  Else    ' User chose No.
    For i = 1 To sRow
      For j = 1 To sCol Step 2
        t = CLng(sArr(i, j))
        If t > 0 Then tArr(t) = tArr(t) & "," & sArr(i, j + 1)
      Next j
    Next i
  End If
 
  For i = tMin To tMax
    If Len(tArr(i)) > 0 Then
      t = CDate(i)
      S = Split(tArr(i), ",")
      For j = 1 To UBound(S)
        k = k + 1
        Res(k, 1) = t: Res(k, 2) = S(j)
      Next j
    End If
  Next i

  With Sheets("Sheet2")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:B" & eRow).ClearContents
    If k > 0 Then .Range("A2:B2").Resize(k) = Res
  End With
 
End Sub

YenLV · 24/10/18

@HieuCD
Cảm ơn anh nhiều, chúc anh mạnh khỏe và hạnh phúc ạ

Nhờ chỉnh sửa công thức: tìm và sắp xếp dữ liệu theo thời gian (3 người xem)

Người dùng đang xem chủ đề này

Ba Tê

Cạo Rồi Khỏi Gội

File đính kèm

HieuCD

Chuyên gia GPE

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!

YenLV

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

Ba Tê

Cạo Rồi Khỏi Gội

HieuCD

Chuyên gia GPE

File đính kèm

YenLV

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