Ghép cặp nhân sự theo nhóm

Liên hệ QC
D

Duchuu77

Thành viên mới
Tham gia
1/3/19
Bài viết
3
Được thích
1
Các bác tư vấn cho em cách sử lý trường hợp này với.
Phòng em có 6 nhân viên và 3 sếp
Giờ phải lên lịch để đi cơ sở bằng cách tự động. ( 1 sếp và 2 nhân viên thành 1 nhóm)
Mà em chưa có giải pháp nào cả.
mà VBA cũng không biết.
Mong các bác giúp đỡ
Em cảm ơn
 

File đính kèm

  • ghepnguoi.xlsx
    12 KB · Đọc: 6
  • manhinh.jpg
    manhinh.jpg
    72.3 KB · Đọc: 12
Cứ mỗi sếp có 2 nhân viên. Đố bạn mỗi nhân viên có mấy sếp?
 
Maika8008 đã viết:
Cứ mỗi sếp có 2 nhân viên. Đố bạn mỗi nhân viên có mấy sếp?
Nhấp chuột vào đây để mở rộng...
Người ta quen gọi sếp, chứ thực ra là trưởng nhóm.

Nếu cứ giữ các nhóm trưởng tại chỗ thì chỉ thay đổi nhân vên thôi.
Cứ 2 nhân viên một nhóm thì được:
12, 34, 56
12, 35, 46
12, 36, 45
13, 24, 56 (thay 3 vào vị trí của 2)
...
14, 23, 56 (thay 4 vào vị trí của 2)
...
15, 23, 46
...
16, 23, 45
...
Có tất cả 18 trường hợp mà 1 nằm trong nhóm 1.
Tương tự, sẽ có 18 trường hợp mà 2 nằm trong nhóm 1, trừ đi 3 trường hợp đi cặp với 1 thì còn lại 15.
Tương tự cho 3, 4, 5
Kết quả là một đống các kiểu nhóm nhân viên.
Đống này đã được sắp xếp để 1 nằm trong nhóm 1
Thêm con toán hoán vị lần lượt để 1 nằm trong nhóm 2, nhóm 3.
Nhức đầu quá. Thôi sáng mai rảnh tính tiếp, không rảnh thì ngồi lót dép chờ mấy quý vị chuyên toán tổ hợp tính.
Dạo này lười lên Wiki tìm mấy bài toán quá.
 
Duchuu77 đã viết:
Các bác tư vấn cho em cách sử lý trường hợp này với.
Phòng em có 6 nhân viên và 3 sếp
Giờ phải lên lịch để đi cơ sở bằng cách tự động. ( 1 sếp và 2 nhân viên thành 1 nhóm)
Mà em chưa có giải pháp nào cả.
mà VBA cũng không biết.
Mong các bác giúp đỡ
Em cảm ơn
Nhấp chuột vào đây để mở rộng...
Chạy sub XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), ToHop, NNhien, Res(), fRow&, eRow&
  Dim N&, sRow&, v&, i&, r&, k&, c&, iR&, tmp$, Sott$
 
fRow = 3 'Dong dau
eRow = Range("B" & Rows.Count).End(xlUp).Row
If eRow < fRow Then Exit Sub
sArr = Range("M3:M8").Value:    N = UBound(sArr)
ToHop = Tohop_N_Chap_K(N, 2):   sRow = UBound(ToHop)

For v = fRow To eRow Step sRow
  ReDim Res(1 To sRow, 1 To 8)
  NNhien = UniqueRand(sRow)
  For i = 1 To sRow 'Ket qua cot 1 va 2
    iR = NNhien(i, 1)
    Res(i, 1) = ToHop(iR, 1)
    Res(i, 2) = ToHop(iR, 2)
    Res(i, 7) = ToHop(iR, 1) & ToHop(iR, 2)
  Next i

TroLai:
  NNhien = UniqueRand(sRow)
  For i = 1 To sRow 'Ket qua cot 3 va 4
    tmp = Res(i, 7)
    For r = 1 To sRow
      iR = NNhien(r, 1)
      If iR > 0 Then
        If InStr(1, tmp, ToHop(iR, 1)) = 0 Then
          If InStr(1, tmp, ToHop(iR, 2)) = 0 Then
            Sott = ChuoiThuTu(N, ToHop(iR, 1) & ToHop(iR, 2) & tmp)
            For k = 1 To i - 1
              If Res(k, 8) = Sott Then Exit For
            Next k
            If k = i Then
              Res(i, 3) = ToHop(iR, 1)
              Res(i, 4) = ToHop(iR, 2)
              Res(i, 8) = Sott
              NNhien(r, 1) = 0
              Exit For
            End If
          End If
        End If
      End If
    Next r
    If r = sRow + 1 Then GoTo TroLai
  Next i

  For i = 1 To sRow 'Ket qua cot 5 va 6
    tmp = Res(i, 8)
    c = 4
    For r = 1 To N
      If InStr(1, tmp, CStr(r)) = 0 Then
        c = c + 1
        Res(i, c) = r
      End If
    Next r
  Next i
 
  For i = 1 To sRow 'Gan ten Nhan vien
    For c = 1 To N
      Res(i, c) = sArr(Res(i, c), 1)
    Next c
  Next i
  Range("C" & v).Resize(sRow, 6) = Res ' gan ket qua 1 chu ky sRow dong
Next v
End Sub

Private Function ChuoiThuTu(N, ByVal ThuTu) As String
  Dim Arr(), Res$, i&
  ReDim Arr(1 To N)
  For i = 1 To Len(ThuTu)
    Arr(Mid(ThuTu, i, 1)) = 1
  Next i
  For i = 1 To N
    If Arr(i) = 1 Then Res = Res & i
  Next i
  ChuoiThuTu = Res
End Function

Private Function Tohop_N_Chap_K(ByVal N&, ByVal k&) As Variant
  'Mang To hop N chap K, bieu dien bang chuoi các ký tu "0" va "1"
  'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
  Dim Arr$(), Res&(), tmp$, j&, p&, s&, sRow&, c&
 
  sRow = Application.Combin(N, k)
  ReDim Arr(1 To sRow, 1 To 1)
  tmp = String(k, "1") & String(N - k, "0")
  p = 1: Arr(p, 1) = tmp
  Do
    j = InStrRev(tmp, "1")
    Mid(tmp, j, 1) = "0"
    Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
    s = 0: p = p + 1:   Arr(p, 1) = tmp
    If InStr(j + 1, tmp, "0") = 0 Then
      s = N - j
      Mid(tmp, j + 1, s) = String(s, "0")
    End If
  Loop Until s = k
  ReDim Res(1 To sRow, 1 To k)
  For s = 1 To sRow
    c = 0
    tmp = Arr(s, 1)
    For j = 1 To N
      If Mid(tmp, j, 1) = "1" Then c = c + 1: Res(s, c) = CStr(j)
    Next j
  Next s
  Tohop_N_Chap_K = Res
End Function

Function UniqueRand(ByVal N As Long) As Variant
  'UniqueRand: mang ngau nhien cac so khong trung tu 1 -> N
  Dim Arr() As Long, i&, RndNum&, tmp&
  ReDim Arr(1 To N, 1 To 1)
  Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If Arr(RndNum, 1) = 0 Then tmp = RndNum Else tmp = Arr(RndNum, 1)
    If Arr(N, 1) = 0 Then Arr(RndNum, 1) = N Else Arr(RndNum, 1) = Arr(N, 1)
    Arr(N, 1) = tmp
    N = N - 1
  Next i
  UniqueRand = Arr
End Function
 

File đính kèm

  • ghepnguoi.xlsm
    27.2 KB · Đọc: 14
bebo021999 đã viết:
Không xét đến giới tính, mà chỉ xét lập nhóm là 1 thiếu sót lớn!
Cần lên kế hoạch xây dựng 1 nhà trẻ tại công ty, sau 9 tháng nữa.
Nhấp chuột vào đây để mở rộng...
Cần phải viết thêm 1 code nữa có tên là sub XepHinh() lưu file với tên là NhaTre.xlsm @!>><
 
HieuCD đã viết:
Chạy sub XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), ToHop, NNhien, Res(), fRow&, eRow&
  Dim N&, sRow&, v&, i&, r&, k&, c&, iR&, tmp$, Sott$
 
fRow = 3 'Dong dau
eRow = Range("B" & Rows.Count).End(xlUp).Row
If eRow < fRow Then Exit Sub
sArr = Range("M3:M8").Value:    N = UBound(sArr)
ToHop = Tohop_N_Chap_K(N, 2):   sRow = UBound(ToHop)

For v = fRow To eRow Step sRow
  ReDim Res(1 To sRow, 1 To 8)
  NNhien = UniqueRand(sRow)
  For i = 1 To sRow 'Ket qua cot 1 va 2
    iR = NNhien(i, 1)
    Res(i, 1) = ToHop(iR, 1)
    Res(i, 2) = ToHop(iR, 2)
    Res(i, 7) = ToHop(iR, 1) & ToHop(iR, 2)
  Next i

TroLai:
  NNhien = UniqueRand(sRow)
  For i = 1 To sRow 'Ket qua cot 3 va 4
    tmp = Res(i, 7)
    For r = 1 To sRow
      iR = NNhien(r, 1)
      If iR > 0 Then
        If InStr(1, tmp, ToHop(iR, 1)) = 0 Then
          If InStr(1, tmp, ToHop(iR, 2)) = 0 Then
            Sott = ChuoiThuTu(N, ToHop(iR, 1) & ToHop(iR, 2) & tmp)
            For k = 1 To i - 1
              If Res(k, 8) = Sott Then Exit For
            Next k
            If k = i Then
              Res(i, 3) = ToHop(iR, 1)
              Res(i, 4) = ToHop(iR, 2)
              Res(i, 8) = Sott
              NNhien(r, 1) = 0
              Exit For
            End If
          End If
        End If
      End If
    Next r
    If r = sRow + 1 Then GoTo TroLai
  Next i

  For i = 1 To sRow 'Ket qua cot 5 va 6
    tmp = Res(i, 8)
    c = 4
    For r = 1 To N
      If InStr(1, tmp, CStr(r)) = 0 Then
        c = c + 1
        Res(i, c) = r
      End If
    Next r
  Next i
 
  For i = 1 To sRow 'Gan ten Nhan vien
    For c = 1 To N
      Res(i, c) = sArr(Res(i, c), 1)
    Next c
  Next i
  Range("C" & v).Resize(sRow, 6) = Res ' gan ket qua 1 chu ky sRow dong
Next v
End Sub

Private Function ChuoiThuTu(N, ByVal ThuTu) As String
  Dim Arr(), Res$, i&
  ReDim Arr(1 To N)
  For i = 1 To Len(ThuTu)
    Arr(Mid(ThuTu, i, 1)) = 1
  Next i
  For i = 1 To N
    If Arr(i) = 1 Then Res = Res & i
  Next i
  ChuoiThuTu = Res
End Function

Private Function Tohop_N_Chap_K(ByVal N&, ByVal k&) As Variant
  'Mang To hop N chap K, bieu dien bang chuoi các ký tu "0" va "1"
  'Thu tu gia tri "1" là thu tu du lieu nguon lay du lieu
  Dim Arr$(), Res&(), tmp$, j&, p&, s&, sRow&, c&
 
  sRow = Application.Combin(N, k)
  ReDim Arr(1 To sRow, 1 To 1)
  tmp = String(k, "1") & String(N - k, "0")
  p = 1: Arr(p, 1) = tmp
  Do
    j = InStrRev(tmp, "1")
    Mid(tmp, j, 1) = "0"
    Mid(tmp, j + 1, s + 1) = String(s + 1, "1")
    s = 0: p = p + 1:   Arr(p, 1) = tmp
    If InStr(j + 1, tmp, "0") = 0 Then
      s = N - j
      Mid(tmp, j + 1, s) = String(s, "0")
    End If
  Loop Until s = k
  ReDim Res(1 To sRow, 1 To k)
  For s = 1 To sRow
    c = 0
    tmp = Arr(s, 1)
    For j = 1 To N
      If Mid(tmp, j, 1) = "1" Then c = c + 1: Res(s, c) = CStr(j)
    Next j
  Next s
  Tohop_N_Chap_K = Res
End Function

Function UniqueRand(ByVal N As Long) As Variant
  'UniqueRand: mang ngau nhien cac so khong trung tu 1 -> N
  Dim Arr() As Long, i&, RndNum&, tmp&
  ReDim Arr(1 To N, 1 To 1)
  Randomize
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If Arr(RndNum, 1) = 0 Then tmp = RndNum Else tmp = Arr(RndNum, 1)
    If Arr(N, 1) = 0 Then Arr(RndNum, 1) = N Else Arr(RndNum, 1) = Arr(N, 1)
    Arr(N, 1) = tmp
    N = N - 1
  Next i
  UniqueRand = Arr
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn ban. Mình chạy được rồi. Cảm ơn rất nhiều
 
vanlinhmt đã viết:
Toàn các bậc thầy về ý tưởng :)
Nhấp chuột vào đây để mở rộng...
Đi cơ sở kiểu này chắc có lẽ gọi là đi đóng gạch thì đúng hơn :D
Bài đã được tự động gộp:

@ Thớt: Thêm 1 cách tham khảo
Mã: 
Option Explicit

Sub xephinh()
Dim nhanvien, slnv
Dim canbo
Dim thongke
Dim thCb
Dim mang, tam0, tam1, tam2
Dim i, j, k, x, z, t, thp
Dim kq

With Sheet5
    nhanvien = .Range("J3:J8")
    slnv = 6
End With
k = Application.Combin(slnv, 2)
thp = Application.Combin(slnv - 2, 2)
ReDim tam0(slnv - 1)
For i = 1 To slnv
    tam0(i - 1) = nhanvien(i, 1)
Next i
ReDim thongke(1 To k, 1 To thp * 2 + 1)
k = 0
For i = 1 To slnv - 1
    For j = i + 1 To slnv
        k = k + 1
        thongke(k, 1) = nhanvien(i, 1) & "+" & nhanvien(j, 1)
        tam1 = tam0
        tam1(i - 1) = tam1(0)
        tam1(j - 1) = tam1(1)
        t = 1
        For x = 2 To 5 - 1
            For z = x + 1 To slnv - 1
                t = t + 1
                thongke(k, t) = tam1(x) & "+" & tam1(z)
                tam2 = tam1
                tam2(x) = tam2(2)
                tam2(z) = tam2(3)
                
                thongke(k, thp + t) = tam2(4) & " + " & tam2(5)
            Next z
        Next x
    Next j
Next i

k = Application.Combin(slnv, 2)
t = Application.Combin(slnv - 2, 2)
i = Application.Permut(3, 3)
k = k * t * i
ReDim kq(1 To k, 1 To 3)
canbo = Array(123, 132, 213, 231, 312, 321)

With CreateObject("Scripting.Dictionary")
    k = 0
    ReDim tam2(1 To 3)
    For Each tam0 In canbo
        x = CLng(Mid(tam0, 1, 1))
        z = CLng(Mid(tam0, 2, 1))
        t = CLng(Mid(tam0, 3, 1))
             
        For i = 1 To UBound(thongke)
            For j = 2 To thp + 1
                tam2(x) = thongke(i, 1)
                tam2(z) = thongke(i, j)
                tam2(t) = thongke(i, thp + j)
                
                tam1 = Join(tam2)
                If .exists(tam1) = 0 Then
                    k = k + 1
                    kq(k, x) = thongke(i, 1)
                    kq(k, z) = thongke(i, j)
                    kq(k, t) = thongke(i, thp + j)
                    
                    .Item(tam1) = ""
                End If
            Next j
        Next i
    Next tam0
End With
With Sheet5
    .Range("C3").Resize(k, UBound(kq, 2)).Clear
    .Range("C3").Resize(k, UBound(kq, 2)) = kq
End With
End Sub
 
Lần chỉnh sửa cuối:
CHAOQUAY đã viết:
Đi cơ sở kiểu này chắc có lẽ gọi là đi đóng gạch thì đúng hơn :D
Bài đã được tự động gộp:

@ Thớt: Thêm 1 cách tham khảo
Mã: 
Option Explicit

Sub xephinh()
Dim nhanvien, slnv
Dim canbo
Dim thongke
Dim thCb
Dim mang, tam0, tam1, tam2
Dim i, j, k, x, z, t, thp
Dim kq

With Sheet5
    nhanvien = .Range("J3:J8")
    slnv = 6
End With
k = Application.Combin(slnv, 2)
thp = Application.Combin(slnv - 2, 2)
ReDim tam0(slnv - 1)
For i = 1 To slnv
    tam0(i - 1) = nhanvien(i, 1)
Next i
ReDim thongke(1 To k, 1 To thp * 2 + 1)
k = 0
For i = 1 To slnv - 1
    For j = i + 1 To slnv
        k = k + 1
        thongke(k, 1) = nhanvien(i, 1) & "+" & nhanvien(j, 1)
        tam1 = tam0
        tam1(i - 1) = tam1(0)
        tam1(j - 1) = tam1(1)
        t = 1
        For x = 2 To 5 - 1
            For z = x + 1 To slnv - 1
                t = t + 1
                thongke(k, t) = tam1(x) & "+" & tam1(z)
                tam2 = tam1
                tam2(x) = tam2(2)
                tam2(z) = tam2(3)
              
                thongke(k, thp + t) = tam2(4) & " + " & tam2(5)
            Next z
        Next x
    Next j
Next i

k = Application.Combin(slnv, 2)
t = Application.Combin(slnv - 2, 2)
i = Application.Permut(3, 3)
k = k * t * i
ReDim kq(1 To k, 1 To 3)
canbo = Array(123, 132, 213, 231, 312, 321)

With CreateObject("Scripting.Dictionary")
    k = 0
    ReDim tam2(1 To 3)
    For Each tam0 In canbo
        x = CLng(Mid(tam0, 1, 1))
        z = CLng(Mid(tam0, 2, 1))
        t = CLng(Mid(tam0, 3, 1))
           
        For i = 1 To UBound(thongke)
            For j = 2 To thp + 1
                tam2(x) = thongke(i, 1)
                tam2(z) = thongke(i, j)
                tam2(t) = thongke(i, thp + j)
              
                tam1 = Join(tam2)
                If .exists(tam1) = 0 Then
                    k = k + 1
                    kq(k, x) = thongke(i, 1)
                    kq(k, z) = thongke(i, j)
                    kq(k, t) = thongke(i, thp + j)
                  
                    .Item(tam1) = ""
                End If
            Next j
        Next i
    Next tam0
End With
With Sheet5
    .Range("C3").Resize(k, UBound(kq, 2)).Clear
    .Range("C3").Resize(k, UBound(kq, 2)) = kq
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác. nhưng của em yêu cầu là trong 1 đoàn là không có sự lăp lại nhóm nhân viên trùng nhau ạ.
Bác HieuCD làm cho em thấy phù hợp hơn. Thank bác
 
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

P
Unsurpassed Сasual Dating - Legitimate Girls
Trả lời
0
Đọc
15
pta289
P
kiencuong030184
  • Question
ẩn hiện dòng, cột có điều kiên
Trả lời
0
Đọc
16
kiencuong030184
kiencuong030184
A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
4
Đọc
96
Hoàng Tuấn 868
H
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
1
Đọc
36
VetMini
V
Emyeuexcel
In theo số thứ tự
Trả lời
2
Đọc
49
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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