Nhờ chuyển danh sách những người cùng đơn vị trên nhiều hàng về trên cùng một hàng (hết người 1 đến người 2,...)

titanic20072007 · 25/3/19

Chào AE GPE. Hôm nay mình có vấn đề khó quá muốn nhờ AE giúp đỡ. Vấn đề là thế này:
Mình có DS cán bộ các đơn vị (mặc định chưa sắp xếp), số lượng cán bộ mỗi đơn vị không cố định nhưng tối đa 10 người. Mình phải in thông báo (bằng trộn thư) cho từng đơn vị (những người của đơn vị nào thì chỉ thông báo cho đơn vị đó biết). Để in theo kiểm trộn thư phải đưa danh sách những người ở cùng đơn vị về trên cùng một dòng (nằm trên nhiều cột) hết thông tin người này đến thông tin người kia cho đến hết người của đơn vị đó rồi chuyển sang đơn vị tiếp theo, cứ thứ thế đến hết các đơn vị. Nếu copy thủ công thì lâu quá vì nhiều đơn vị, nhiều người và có thể nhầm lẫn (rất nguy hiểm).
Mình nhờ AE trong GPE viết giúp code VBA để thực hiện công việc trên, dữ liệu mẫu có trong tệp đính kèm. Rất mong AE giúp đỡ. Thank!

Ba Tê · 26/3/19

titanic20072007 đã viết:
Chào AE GPE. Hôm nay mình có vấn đề khó quá muốn nhờ AE giúp đỡ. Vấn đề là thế này:
Mình có DS cán bộ các đơn vị (mặc định chưa sắp xếp), số lượng cán bộ mỗi đơn vị không cố định nhưng tối đa 10 người. Mình phải in thông báo (bằng trộn thư) cho từng đơn vị (những người của đơn vị nào thì chỉ thông báo cho đơn vị đó biết). Để in theo kiểm trộn thư phải đưa danh sách những người ở cùng đơn vị về trên cùng một dòng (nằm trên nhiều cột) hết thông tin người này đến thông tin người kia cho đến hết người của đơn vị đó rồi chuyển sang đơn vị tiếp theo, cứ thứ thế đến hết các đơn vị. Nếu copy thủ công thì lâu quá vì nhiều đơn vị, nhiều người và có thể nhầm lẫn (rất nguy hiểm).
Mình nhờ AE trong GPE viết giúp code VBA để thực hiện công việc trên, dữ liệu mẫu có trong tệp đính kèm. Rất mong AE giúp đỡ. Thank!

Bạn Copy Sub này vào Module rồi chạy thử xem sao.

PHP:

Public Sub sGpe()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Rws As Long, CoL As Long, DV As String
With Sheets("Du lieu")
    sArr = .Range("B8", .Range("B8").End(xlDown)).Resize(, 20).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 50)
End With
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        DV = UCase(sArr(I, 6))
        If Not .Exists(DV) Then
            K = K + 1
            .Item(DV) = K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 6)
            dArr(K, 3) = sArr(I, 1)
            dArr(K, 4) = sArr(I, 2)
            dArr(K, 5) = sArr(I, 5)
            dArr(K, 6) = sArr(I, 17)
            dArr(K, 50) = 7
        Else
            Rws = .Item(DV)
            CoL = dArr(Rws, 50)
            dArr(Rws, CoL) = sArr(I, 1)
            dArr(Rws, CoL + 1) = sArr(I, 2)
            dArr(Rws, CoL + 2) = sArr(I, 5)
            dArr(Rws, CoL + 3) = sArr(I, 17)
            dArr(Rws, 50) = CoL + 4
        End If
    Next I
End With
With Sheets("In")
    .Range("B2").Resize(100, 42).ClearContents
    .Range("B2").Resize(K, 42) = dArr
End With

Phuocam · 26/3/19

Nếu dữ liệu đã được sort theo tên đơn vị, có thể dùng:

PHP:

Public Sub test()

Dim sArr(), dArr(), I As Long, K As Long, R As Long, VT As Long, DV As String
With Sheets("Du lieu")
    sArr = .Range("B8", .Range("B8").End(xlDown)).Resize(, 20).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 50)
End With
    For I = 1 To R
      If UCase(sArr(I, 6)) <> DV Then
        DV = UCase(sArr(I, 6))
        K = K + 1
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 6)
        VT = -1
      End If
        VT = VT + 4
        dArr(K, VT) = sArr(I, 1)
        dArr(K, VT + 1) = sArr(I, 2)
        dArr(K, VT + 2) = sArr(I, 5)
        dArr(K, VT + 3) = sArr(I, 17)
        
    Next I

With Sheets("In")
    .Range("B2").Resize(100, 50).ClearContents
    .Range("B2").Resize(K, 50) = dArr
End With
End Sub

HieuCD · 26/3/19

Góp vui

Mã:

Sub GPE()
  Dim sArr(), tArr, Res(), i As Long, k As Long, iKey As String
  tArr = Array(1, 2, 5, 17)
  With Sheets("Du lieu")
    sArr = .Range("B8", .Range("R1000000").End(xlUp)).Value
    ReDim Res(1 To UBound(sArr), 1 To 42)
  End With
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(sArr)
      iKey = UCase(sArr(i, 6))
      If Not .Exists(iKey) Then
        k = k + 1
        .Item(iKey) = Array(k, 3)
        Res(k, 1) = k:        Res(k, 2) = iKey
      End If
      s = .Item(iKey)
      For j = 0 To UBound(tArr)
        Res(s(0), s(1) + j) = sArr(i, tArr(j))
      Next j
      .Item(iKey) = Array(s(0), s(1) + 4)
    Next i
  End With
  With Sheets("In")
    .Range("B2").Resize(UBound(sArr), 42).ClearContents
    .Range("B2").Resize(k, 42) = Res
  End With
End Sub

titanic20072007 · 26/3/19

Ba Tê đã viết:

Bạn Copy Sub này vào Module rồi chạy thử xem sao.

PHP:

Public Sub sGpe()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Rws As Long, CoL As Long, DV As String
With Sheets("Du lieu")
    sArr = .Range("B8", .Range("B8").End(xlDown)).Resize(, 20).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 50)
End With
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        DV = UCase(sArr(I, 6))
        If Not .Exists(DV) Then
            K = K + 1
            .Item(DV) = K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 6)
            dArr(K, 3) = sArr(I, 1)
            dArr(K, 4) = sArr(I, 2)
            dArr(K, 5) = sArr(I, 5)
            dArr(K, 6) = sArr(I, 17)
            dArr(K, 50) = 7
        Else
            Rws = .Item(DV)
            CoL = dArr(Rws, 50)
            dArr(Rws, CoL) = sArr(I, 1)
            dArr(Rws, CoL + 1) = sArr(I, 2)
            dArr(Rws, CoL + 2) = sArr(I, 5)
            dArr(Rws, CoL + 3) = sArr(I, 17)
            dArr(Rws, 50) = CoL + 4
        End If
    Next I
End With
With Sheets("In")
    .Range("B2").Resize(100, 42).ClearContents
    .Range("B2").Resize(K, 42) = dArr
End With

Cảm ơn Ba Tê nhiều code chạy rất nhanh.

Bài đã được tự động gộp: 26/3/19

phuocam đã viết:

Nếu dữ liệu đã được sort theo tên đơn vị, có thể dùng:

PHP:

Public Sub test()

Dim sArr(), dArr(), I As Long, K As Long, R As Long, VT As Long, DV As String
With Sheets("Du lieu")
    sArr = .Range("B8", .Range("B8").End(xlDown)).Resize(, 20).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 50)
End With
    For I = 1 To R
      If UCase(sArr(I, 6)) <> DV Then
        DV = UCase(sArr(I, 6))
        K = K + 1
        dArr(K, 1) = K
        dArr(K, 2) = sArr(I, 6)
        VT = -1
      End If
        VT = VT + 4
        dArr(K, VT) = sArr(I, 1)
        dArr(K, VT + 1) = sArr(I, 2)
        dArr(K, VT + 2) = sArr(I, 5)
        dArr(K, VT + 3) = sArr(I, 17)
       
    Next I

With Sheets("In")
    .Range("B2").Resize(100, 50).ClearContents
    .Range("B2").Resize(K, 50) = dArr
End With
End Sub

Cảm ơn Phuocam đã giúp.

Nhờ chuyển danh sách những người cùng đơn vị trên nhiều hàng về trên cùng một hàng (hết người 1 đến người 2,...)

titanic20072007

Thành viên thường trực

File đính kèm

Ba Tê

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

Phuocam

Thành viên mới

HieuCD

Chuyên gia GPE

titanic20072007

Thành viên thường trự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