[Xin giúp đỡ] Tìm dữ liệu tương ứng trên cột và chuyển sang dạng hàng

Liên hệ QC
G

gameonly308

Thành viên hoạt động
Tham gia
4/5/09
Bài viết
197
Được thích
10
Em có dữ liệu các xe với Số ngăn và Lượng xuất tương ứng với từng ngăn tại Buồng xuất tương ứng trên Sheet1.
Các bác xem có code nào quét giúp em chuyển nó sang dạng hàng bên Sheet2 được không ạ?.
Các xe có số ngăn bất kỳ, lúc 2 ngăn, lúc 3 ngăn, lúc 4 ngăn không cố định. Chỉ có Lượng xuất cố định ứng với từng ngăn là không thay đổi.
Em cảm ơn.
 

File đính kèm

  • 1.jpg
    1.jpg
    154.5 KB · Đọc: 14
  • 2.jpg
    2.jpg
    369.7 KB · Đọc: 12
  • Book1.xlsx
    10.6 KB · Đọc: 10
gameonly308 đã viết:
Em có dữ liệu các xe với Số ngăn và Lượng xuất tương ứng với từng ngăn tại Buồng xuất tương ứng trên Sheet1.
Các bác xem có code nào quét giúp em chuyển nó sang dạng hàng bên Sheet2 được không ạ?.
Các xe có số ngăn bất kỳ, lúc 2 ngăn, lúc 3 ngăn, lúc 4 ngăn không cố định. Chỉ có Lượng xuất cố định ứng với từng ngăn là không thay đổi.
Em cảm ơn.
Nhấp chuột vào đây để mở rộng...
Bạn thử code này.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 1)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), a
              arr1(a, 1) = arr(i, 3)
            End If
            dk = arr(i, 1) & "#" & arr(i, 3)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "#" & arr(i, 1)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "##" & arr(i, 4)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
       Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         .Range("A3").Resize(a).Value = arr1
         darr = .Range("A2:AA2").Resize(a + 1).Value
         For i = 2 To UBound(darr, 1)
             For j = 2 To 9
                 dk = darr(1, j) & "#" & darr(i, 1)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 2)
                 End If
             Next j
             For j = 10 To 17
                 dk = darr(i, 1) & "#" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 5)
                 End If
             Next j
             For j = 18 To UBound(darr, 2)
                 dk = darr(i, 1) & "##" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 1)
                 End If
             Next j
        Next i
        .Range("A2:AA2").Resize(a + 1).Value = darr
  End With
End Sub
 

File đính kèm

  • Book1 (1).xlsm
    19.7 KB · Đọc: 5
snow25 đã viết:
Bạn thử code này.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 1)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), a
              arr1(a, 1) = arr(i, 3)
            End If
            dk = arr(i, 1) & "#" & arr(i, 3)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "#" & arr(i, 1)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "##" & arr(i, 4)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
       Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         .Range("A3").Resize(a).Value = arr1
         darr = .Range("A2:AA2").Resize(a + 1).Value
         For i = 2 To UBound(darr, 1)
             For j = 2 To 9
                 dk = darr(1, j) & "#" & darr(i, 1)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 2)
                 End If
             Next j
             For j = 10 To 17
                 dk = darr(i, 1) & "#" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 5)
                 End If
             Next j
             For j = 18 To UBound(darr, 2)
                 dk = darr(i, 1) & "##" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 1)
                 End If
             Next j
        Next i
        .Range("A2:AA2").Resize(a + 1).Value = darr
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bài nầy dùng dic để nhận diện số xe và thứ tự dòng kết quả
Dùng "Ngăn xuất" để xác định thứ tự cột kết quả
 
snow25 đã viết:
À em hiểu rồi cảm ơn anh ạ.Mai em code lại.Đỡ 1 vòng lặp sau.Chỉ cần duyệt 1 lần.
Nhấp chuột vào đây để mở rộng...
Bác code lại cho em học với ạ, em cảm ơn.
Bài đã được tự động gộp:

snow25 đã viết:
Bạn thử code này.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 1)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), a
              arr1(a, 1) = arr(i, 3)
            End If
            dk = arr(i, 1) & "#" & arr(i, 3)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "#" & arr(i, 1)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
            dk = arr(i, 3) & "##" & arr(i, 4)
            If Not dic.exists(dk) Then
               dic.Add dk, i
            End If
       Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         .Range("A3").Resize(a).Value = arr1
         darr = .Range("A2:AA2").Resize(a + 1).Value
         For i = 2 To UBound(darr, 1)
             For j = 2 To 9
                 dk = darr(1, j) & "#" & darr(i, 1)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 2)
                 End If
             Next j
             For j = 10 To 17
                 dk = darr(i, 1) & "#" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 5)
                 End If
             Next j
             For j = 18 To UBound(darr, 2)
                 dk = darr(i, 1) & "##" & darr(1, j)
                 b = dic.Item(dk)
                 If b Then
                    darr(i, j) = arr(b, 1)
                 End If
             Next j
        Next i
        .Range("A2:AA2").Resize(a + 1).Value = darr
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào bác, với trường hợp em đưa ra là 1 xe chỉ lấy hàng có 1 lần. Em xin bác góp ý thêm là:
1. Em muốn load là Ứng với mỗi ngăn xuất, sẽ hiện buồng xuất tương ứng: VD như xe 29H 18044 thì sẽ là : Ngăn 1 - Buồng 2
Ngăn 2 - Buồng 2; Ngăn 3 - Buồng 1;
2. Em chạy dữ liệu với trường hợp là 1 xe vào lấy hàng 2 lần thì lần thứ 2 không add vào dữ liệu bác ạ (Với trường hợp chuyến 2 thì em nghĩ là Dựa vào cái file Thời gian được không bác, vì Thường các chuyến cách nhau 3-40 phút, còn ở trong file là em copy ví dụ thôi ạ). Bác xem hộ em, em cảm ơn!
 

File đính kèm

  • Book1 (1).xlsm
    20.9 KB · Đọc: 6
  • bx.jpg
    bx.jpg
    372.1 KB · Đọc: 7
  • x1.jpg
    x1.jpg
    469 KB · Đọc: 6
Lần chỉnh sửa cuối:
gameonly308 đã viết:
Bác code lại cho em học với ạ, em cảm ơn.
Bài đã được tự động gộp:


Em chào bác, với trường hợp em đưa ra là 1 xe chỉ lấy hàng có 1 lần. Em xin bác góp ý thêm là:
1. Em muốn load là Ứng với mỗi ngăn xuất, sẽ hiện buồng xuất tương ứng: VD như xe 29H 18044 thì sẽ là : Ngăn 1 - Buồng 2
Ngăn 2 - Buồng 2; Ngăn 3 - Buồng 1;
2. Em chạy dữ liệu với trường hợp là 1 xe vào lấy hàng 2 lần thì lần thứ 2 không add vào dữ liệu bác ạ (Với trường hợp chuyến 2 thì em nghĩ là Dựa vào cái file Thời gian được không bác, vì Thường các chuyến cách nhau 3-40 phút, còn ở trong file là em copy ví dụ thôi ạ). Bác xem hộ em, em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn xem.Nếu mà trường hợp có 2 chuyến thì mình nghĩ bạn thêm 1 cột nữa để ghi số chuyến vào.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long, c As Integer, T As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         arr = .Range("A2:AA2").Value
         For i = 2 To 9
             dic.Item(arr(1, i) & "CD") = i
         Next i
         For i = 10 To 17
             dic.Item(arr(1, i) & "TT") = i
         Next i
         For i = 18 To 27
             dic.Item(arr(1, i) & "BX") = i
         Next i
    End With
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 27)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), Array(a, arr(i, 1))
              arr1(a, 1) = arr(i, 3)
            End If
            b = dic.Item(arr(i, 3))(0)
            c = dic.Item(arr(i, 1) & "CD")
            arr1(b, c) = arr(i, 2)
            c = dic.Item(arr(i, 1) & "TT")
            arr1(b, c) = arr(i, 5)
            c = dic.Item(arr(i, 1) & "BX")
            arr1(b, c) = arr(i, 4)
        Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         If a Then .Range("A3").Resize(a, 27).Value = arr1
   End With
End Sub
 
snow25 đã viết:
Bạn xem.Nếu mà trường hợp có 2 chuyến thì mình nghĩ bạn thêm 1 cột nữa để ghi số chuyến vào.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long, c As Integer, T As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         arr = .Range("A2:AA2").Value
         For i = 2 To 9
             dic.Item(arr(1, i) & "CD") = i
         Next i
         For i = 10 To 17
             dic.Item(arr(1, i) & "TT") = i
         Next i
         For i = 18 To 27
             dic.Item(arr(1, i) & "BX") = i
         Next i
    End With
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 27)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), Array(a, arr(i, 1))
              arr1(a, 1) = arr(i, 3)
            End If
            b = dic.Item(arr(i, 3))(0)
            c = dic.Item(arr(i, 1) & "CD")
            arr1(b, c) = arr(i, 2)
            c = dic.Item(arr(i, 1) & "TT")
            arr1(b, c) = arr(i, 5)
            c = dic.Item(arr(i, 1) & "BX")
            arr1(b, c) = arr(i, 4)
        Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         If a Then .Range("A3").Resize(a, 27).Value = arr1
   End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác đã giúp đỡ ạ, vấn đề chuyến 2 của em là em lấy từ sql ra ạ, nên thành ra ko tự đánh chuyến 2 được. Bác xem có thể set theo time được ko bác.
 
gameonly308 đã viết:
Đây bác, nhiều trường hợp xe lấy 2 lần với khung giờ khác nhau bác ạ
Nhấp chuột vào đây để mở rộng...
Bạn chạy sub này nhé.Yêu cầu là các xe xếp theo thứ tự nhé.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long, c As Integer, T As String
    Dim s As String, d As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         arr = .Range("A2:AA2").Value
         For i = 2 To 9
             dic.Item(arr(1, i) & "CD") = i
         Next i
         For i = 10 To 17
             dic.Item(arr(1, i) & "TT") = i
         Next i
         For i = 18 To 27
             dic.Item(arr(1, i) & "BX") = i
         Next i
    End With
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 27)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), Array(a, "#" & arr(i, 1) & "#")
              arr1(a, 1) = arr(i, 3)
            Else
              s = dic.Item(arr(i, 3))(1)
              d = dic.Item(arr(i, 3))(0)
              If InStr(1, s, "#" & arr(i, 1) & "#") Then
                 a = a + 1
                 arr1(a, 1) = arr(i, 3)
                 dic.Item(arr(i, 3)) = Array(a, "#" & arr(i, 1) & "#")
              Else
                 s = s & arr(i, 1) & "#"
                 dic.Item(arr(i, 3)) = Array(d, s)
              End If
            End If
            b = dic.Item(arr(i, 3))(0)
            c = dic.Item(arr(i, 1) & "CD")
            arr1(b, c) = arr(i, 2)
            c = dic.Item(arr(i, 1) & "TT")
            arr1(b, c) = arr(i, 5)
            c = dic.Item(arr(i, 1) & "BX")
            arr1(b, c) = arr(i, 4)
        Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         If a Then .Range("A3").Resize(a, 27).Value = arr1
   End With
End Sub
 

File đính kèm

  • Book1 (1) (1).xlsm
    49.6 KB · Đọc: 4
snow25 đã viết:
Bạn chạy sub này nhé.Yêu cầu là các xe xếp theo thứ tự nhé.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long, c As Integer, T As String
    Dim s As String, d As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         arr = .Range("A2:AA2").Value
         For i = 2 To 9
             dic.Item(arr(1, i) & "CD") = i
         Next i
         For i = 10 To 17
             dic.Item(arr(1, i) & "TT") = i
         Next i
         For i = 18 To 27
             dic.Item(arr(1, i) & "BX") = i
         Next i
    End With
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 27)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), Array(a, "#" & arr(i, 1) & "#")
              arr1(a, 1) = arr(i, 3)
            Else
              s = dic.Item(arr(i, 3))(1)
              d = dic.Item(arr(i, 3))(0)
              If InStr(1, s, "#" & arr(i, 1) & "#") Then
                 a = a + 1
                 arr1(a, 1) = arr(i, 3)
                 dic.Item(arr(i, 3)) = Array(a, "#" & arr(i, 1) & "#")
              Else
                 s = s & arr(i, 1) & "#"
                 dic.Item(arr(i, 3)) = Array(d, s)
              End If
            End If
            b = dic.Item(arr(i, 3))(0)
            c = dic.Item(arr(i, 1) & "CD")
            arr1(b, c) = arr(i, 2)
            c = dic.Item(arr(i, 1) & "TT")
            arr1(b, c) = arr(i, 5)
            c = dic.Item(arr(i, 1) & "BX")
            arr1(b, c) = arr(i, 4)
        Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         If a Then .Range("A3").Resize(a, 27).Value = arr1
   End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác. Do đang đi cv k có máy tính, khi nào về em chạy sẽ phản hồi lại sau ạ. Mong nếu có vấn đề gì thì bác tư vấn thêm giúp em với ạ!
 
snow25 đã viết:
Bạn chạy sub này nhé.Yêu cầu là các xe xếp theo thứ tự nhé.
Mã: 
Sub linhtinh()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, a As Long, dk As String, darr, b As Long, c As Integer, T As String
    Dim s As String, d As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
         arr = .Range("A2:AA2").Value
         For i = 2 To 9
             dic.Item(arr(1, i) & "CD") = i
         Next i
         For i = 10 To 17
             dic.Item(arr(1, i) & "TT") = i
         Next i
         For i = 18 To 27
             dic.Item(arr(1, i) & "BX") = i
         Next i
    End With
    With Sheets("sheet1")
         lr = .Range("D" & Rows.Count).End(xlUp).Row
         arr = .Range("C2:G" & lr).Value
    End With
        ReDim arr1(1 To UBound(arr, 1), 1 To 27)
        For i = 1 To UBound(arr, 1)
            If Not dic.exists(arr(i, 3)) Then
              a = a + 1
              dic.Add arr(i, 3), Array(a, "#" & arr(i, 1) & "#")
              arr1(a, 1) = arr(i, 3)
            Else
              s = dic.Item(arr(i, 3))(1)
              d = dic.Item(arr(i, 3))(0)
              If InStr(1, s, "#" & arr(i, 1) & "#") Then
                 a = a + 1
                 arr1(a, 1) = arr(i, 3)
                 dic.Item(arr(i, 3)) = Array(a, "#" & arr(i, 1) & "#")
              Else
                 s = s & arr(i, 1) & "#"
                 dic.Item(arr(i, 3)) = Array(d, s)
              End If
            End If
            b = dic.Item(arr(i, 3))(0)
            c = dic.Item(arr(i, 1) & "CD")
            arr1(b, c) = arr(i, 2)
            c = dic.Item(arr(i, 1) & "TT")
            arr1(b, c) = arr(i, 5)
            c = dic.Item(arr(i, 1) & "BX")
            arr1(b, c) = arr(i, 4)
        Next i
    With Sheets("sheet2")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AA" & lr).ClearContents
         If a Then .Range("A3").Resize(a, 27).Value = arr1
   End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào bác, bác xem mảng này tnao bác hướng dẫn em với ạ.
www.giaiphapexcel.com

[Xin Giúp Đỡ]Ẩn Mouse Curso sau 5s không di chuyển

Chào các bác, em muốn hỏi làm cách nào để khi em ở Sheet1 mà chuột không di chuyển thì sau 5s nó sẽ ẩn đi. Em cảm ơn ạ
www.giaiphapexcel.com www.giaiphapexcel.com
 
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

quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
Trả lời
7
Đọc
911
quangminhici
quangminhici
S
Cần giúp đỡ hàm đếm
Trả lời
10
Đọc
178
Phan Thế Hiệp
Phan Thế Hiệp
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
0
Đọc
20
8589934592
8
PhiTQ-ME
  • Question
Nhờ trợ giúp sửa VBA tính diễn giải khối lượng
Trả lời
2
Đọc
58
PhiTQ-ME
PhiTQ-ME
duongthe1505
Xin công cụ chuyển dữ liệu từ csv sang định dạng cố định excel
Trả lời
1
Đọc
45
DeTong
D
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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