Tạo file nhóm ngẫu nhiên mã khách hàng

toanxn · 2/9/21

Kính chào thầy/cô và Anh/Chị!
Em cần tạo 1 file (file đính kèm) Cột B em quét mã vạch khách hàng (yêu cầu khi quét mã con trỏ tự động nhảy xuống hàng B1, B2,...Bn)
Cột C là cột nhóm khách hàng, các mã số cách nhau bằng dấu ; khi ấn lệnh "CUT" (chi tiết em có ghi rõ trong file excel đính kèm)
Em mới chỉ tập tành code VBA nên rất mong quý Thầy/Cô và Anh/Chị chỉ dạy,
Trân trọng cám ơn.

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Kính chào thầy/cô và Anh/Chị!
Em cần tạo 1 file (file đính kèm) Cột B em quét mã vạch khách hàng (yêu cầu khi quét mã con trỏ tự động nhảy xuống hàng B1, B2,...Bn)
Cột C là cột nhóm khách hàng, các mã số cách nhau bằng dấu ; khi ấn lệnh "CUT" (chi tiết em có ghi rõ trong file excel đính kèm)
Em mới chỉ tập tành code VBA nên rất mong quý Thầy/Cô và Anh/Chị chỉ dạy,
Trân trọng cám ơn.

Tôi thử viết code cho bạn, nếu chưa OK thì cho ý kiến nha:

PHP:

Sub IDCutting()
    Dim arrID
    Dim shtTrangTinh As Worksheet
    Dim e As Long, k As Long, r As Long, lngFirstRow As Long
    Set shtTrangTinh = Sheets("Trang_tính1")
    lngFirstRow = shtTrangTinh.Range("E2").Value
    
    If lngFirstRow = 0 Then
        shtTrangTinh.Range("E2").Value = 2
        lngFirstRow = 2
    End If
    
    e = shtTrangTinh.Range("B" & Rows.Count).End(xlUp).Row
    If e < lngFirstRow Then
        Exit Sub
    End If
    
    arrID = shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Value
    k = shtTrangTinh.Range("C" & Rows.Count).End(xlUp).Row + 1
    
    If IsArray(arrID) Then
        Dim strNoiChuoi As String
        strNoiChuoi = arrID(1, 1)
        For r = 2 To UBound(arrID)
            strNoiChuoi = strNoiChuoi & ";" & arrID(r, 1)
        Next
        shtTrangTinh.Range("C" & k).Value = strNoiChuoi
    Else
        shtTrangTinh.Range("C" & k).Value = arrID
    End If
    shtTrangTinh.Range("E2").Value = e + 1
End Sub

Lưu ý tại ô màu đỏ nhé, bạn không được xóa con số mà nó hiển thị, nếu bạn muốn nó không hiện lên thì lấy cái nút CUT che nó lại.

toanxn · 2/9/21

Chào nghĩa đẹp trai!
Cám ơn anh quá chuẩn rồi, nhưng khi quét mã vạch thì nó chạy từ hàng A sang hàng B, Anh giúp em làm sao nó chạy cố định Hàng B không giới hạn.
Cám ơn anh rất nhiều!

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Chào nghĩa đẹp trai!
Cám ơn anh quá chuẩn rồi, nhưng khi quét mã vạch thì nó chạy từ hàng A sang hàng B, Anh giúp em làm sao nó chạy cố định Hàng B không giới hạn.
Cám ơn anh rất nhiều!

Bạn nói là cái máy quét nó tự động động chạy ở hàng A sang hàng B? Hàng hay là cột vậy bạn?
Mà thiết bị nó quét xong nó lập trình là ghi vào CỘT A thì làm sao mà thay đổi được?
Mà bạn cho dữ liệu thật lên file nó thế nào?

toanxn · 2/9/21

Hoàng Trọng Nghĩa đã viết:
Bạn nói là cái máy quét nó tự động động chạy ở hàng A sang hàng B? Hàng hay là cột vậy bạn?
Mà thiết bị nó quét xong nó lập trình là ghi vào CỘT A thì làm sao mà thay đổi được?
Mà bạn cho dữ liệu thật lên file nó thế nào?

Mình để con trỏ ở cột B mã khách gồm 10 ký tự, khi quét nó cứ nhảy sang cột C, D, ... Mình muốn nó cố định, khi quét xong B1 thì con trỏ nhảy sang cột B2 để quét tiếp.

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Mình để con trỏ ở cột B mã khách gồm 10 ký tự, khi quét nó cứ nhảy sang cột C, D, ... Mình muốn nó cố định, khi quét xong B1 thì con trỏ nhảy sang cột B2 để quét tiếp.

Ý của bạn là sau khi bấm nút CUT thì ô kế tiếp của cột B được chọn vào phải vậy không?

toanxn · 2/9/21

Hoàng Trọng Nghĩa đã viết:
Ý của bạn là sau khi bấm nút CUT thì ô kế tiếp của cột B được chọn vào phải vậy không?

Dúng rồi anh. anh sửa nó tăng vô hạn giúp em. em cám ơn

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Dúng rồi anh. anh sửa nó tăng vô hạn giúp em. em cám ơn

Bạn thay code cũ bằng code dưới đây:

PHP:

Sub IDCutting()
    Dim arrID
    Dim shtTrangTinh As Worksheet
    Dim e As Long, k As Long, r As Long, lngFirstRow As Long
    Set shtTrangTinh = Sheets("Trang_tính1")
    lngFirstRow = shtTrangTinh.Range("E2").Value
    
    If lngFirstRow = 0 Then
        shtTrangTinh.Range("E2").Value = 2
        lngFirstRow = 2
    End If
    
    e = shtTrangTinh.Range("B" & Rows.Count).End(xlUp).Row
    If e < lngFirstRow Then
        shtTrangTinh.Range("B" & e + 1).Select
        Exit Sub
    End If
    
    arrID = shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Value
    k = shtTrangTinh.Range("C" & Rows.Count).End(xlUp).Row + 1
    
    If IsArray(arrID) Then
        Dim strNoiChuoi As String
        strNoiChuoi = arrID(1, 1)
        For r = 2 To UBound(arrID)
            strNoiChuoi = strNoiChuoi & ";" & arrID(r, 1)
        Next
        shtTrangTinh.Range("C" & k).Value = strNoiChuoi
    Else
        shtTrangTinh.Range("C" & k).Value = arrID
    End If
    shtTrangTinh.Range("E2").Value = e + 1
    shtTrangTinh.Range("B" & e + 1).Select
End Sub

toanxn · 2/9/21

Hoàng Trọng Nghĩa đã viết:

Bạn thay code cũ bằng code dưới đây:

PHP:

Sub IDCutting()
    Dim arrID
    Dim shtTrangTinh As Worksheet
    Dim e As Long, k As Long, r As Long, lngFirstRow As Long
    Set shtTrangTinh = Sheets("Trang_tính1")
    lngFirstRow = shtTrangTinh.Range("E2").Value
   
    If lngFirstRow = 0 Then
        shtTrangTinh.Range("E2").Value = 2
        lngFirstRow = 2
    End If
   
    e = shtTrangTinh.Range("B" & Rows.Count).End(xlUp).Row
    If e < lngFirstRow Then
        shtTrangTinh.Range("B" & e + 1).Select
        Exit Sub
    End If
   
    arrID = shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Value
    k = shtTrangTinh.Range("C" & Rows.Count).End(xlUp).Row + 1
   
    If IsArray(arrID) Then
        Dim strNoiChuoi As String
        strNoiChuoi = arrID(1, 1)
        For r = 2 To UBound(arrID)
            strNoiChuoi = strNoiChuoi & ";" & arrID(r, 1)
        Next
        shtTrangTinh.Range("C" & k).Value = strNoiChuoi
    Else
        shtTrangTinh.Range("C" & k).Value = arrID
    End If
    shtTrangTinh.Range("E2").Value = e + 1
    shtTrangTinh.Range("B" & e + 1).Select
End Sub

Cám ơn anh, tuy nhiên lỗi gì mà sao quét mã nó vẫn cứ nhảy như video anh nhỉ!
https://files.fm/u/jacprec5p

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Cám ơn anh, tuy nhiên lỗi gì mà sao quét mã nó vẫn cứ nhảy như video anh nhỉ!
https://files.fm/u/jacprec5p

Tôi không biết lập trình máy nó thế nào, vậy thì bạn nhờ bên cung cấp máy chỉnh nó nhé. Tôi không thể can thiệp vào thiết bị được.

toanxn · 2/9/21

Hoàng Trọng Nghĩa đã viết:
Tôi không biết lập trình máy nó thế nào, vậy thì bạn nhờ bên cung cấp máy chỉnh nó nhé. Tôi không thê can thiệp vào thiết bị được.

Dạ cám ơn anh nghĩa đẹp trai. anh hỗ trợ vậy là tới nóc rồi, chúc anh buổi tối vui vẻ

Hoàng Trọng Nghĩa · 2/9/21

toanxn đã viết:
Dạ cám ơn anh nghĩa đẹp trai. anh hỗ trợ vậy là tới nóc rồi, chúc anh buổi tối vui vẻ

Tôi suy nghĩ rồi, bạn thử kết hợp luôn sự kiện Change trong sheet thử xem có thể thực hiện được không:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row > 1 And Target.Column = 2 Then
        If Target.Value > "" Then Target.Offset(1).Select
    End If
End Sub

toanxn · 3/9/21

Hoàng Trọng Nghĩa đã viết:
Tôi suy nghĩ rồi, bạn thử kết hợp luôn sự kiện Change trong sheet thử xem có thể thực hiện được không:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 1 And Target.Column = 2 Then If Target.Value > "" Then Target.Offset(1).Select End If End Sub

Cám ơn Anh nhiều. nó đã hoạt động như ý muốn

toanxn · 3/9/21

Chào anh, nếu mình muốn mỗi lần ấn CUT nó sẽ tô màu với số tương ứng ở cột C được không anh?

Hoàng Tuấn 868 · 3/9/21

toanxn đã viết:
Chào anh, nếu mình muốn mỗi lần ấn CUT nó sẽ tô màu với số tương ứng ở cột C được không anh?View attachment 265348

Cái này thực hiện được nhưng sau một hồi thì trang tính của bạn thành bức tranh Đông Hồ và tốc độ thì đủ để thi đấu với rùa đấy nhé.

toanxn · 3/9/21

Hoàng Tuấn 868 đã viết:
Cái này thực hiện được nhưng sau một hồi thì trang tính của bạn thành bức tranh Đông Hồ và tốc độ thì đủ để thi đấu với rùa đấy nhé.

Nếu mình chỉ sử dụng 4 màu thôi thì có ảnh hưởng gì không bạn?

Hoàng Tuấn 868 · 3/9/21

toanxn đã viết:
Nếu mình chỉ sử dụng 4 màu thôi thì có ảnh hưởng gì không bạn?

Cứ tô màu là file nặng lên rồi, không cần biết bao nhiêu mầu bạn ạ.

toanxn · 3/9/21

Hoàng Tuấn 868 đã viết:
Cứ tô màu là file nặng lên rồi, không cần biết bao nhiêu mầu bạn ạ.

cám ơn bạn nhiều

Hoàng Trọng Nghĩa · 3/9/21

toanxn đã viết:
Chào anh, nếu mình muốn mỗi lần ấn CUT nó sẽ tô màu với số tương ứng ở cột C được không anh?View attachment 265348

Rất đơn giản nha bạn, không vấn đề gì đâu! Tôi làm cho bạn 4 màu, nếu muốn nhiều màu hơn thì tự bạn chèn thêm trong Select Case nhé.

PHP:

Sub IDCutting_HTN()
    Const clrBlue As Long = &HFFFF80
    Const clrGreen As Long = &HC0FFC0
    Const clrYellow As Long = &HC0FFFF
    Const clrPink As Long = &HFFC0FF
    Dim arrID
    Dim shtTrangTinh As Worksheet
    Dim e As Long, k As Long, r As Long, lngFirstRow As Long, lngColor As Long
    Set shtTrangTinh = Sheets("Trang_tính1")
    lngFirstRow = shtTrangTinh.Range("E2").Value
   
    If lngFirstRow = 0 Then
        shtTrangTinh.Range("E2").Value = 2
        lngFirstRow = 2
    End If
   
    e = shtTrangTinh.Range("B" & Rows.Count).End(xlUp).Row
    If e < lngFirstRow Then
        shtTrangTinh.Range("B" & e + 1).Select
        Exit Sub
    End If
   
    Select Case shtTrangTinh.Range("B" & lngFirstRow - 1).Interior.Color
    Case clrBlue
        lngColor = clrGreen
    Case clrGreen
        lngColor = clrYellow
    Case clrYellow
        lngColor = clrPink
    Case Else
        lngColor = clrBlue
    End Select
   
    shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Interior.Color = lngColor
   
    arrID = shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Value
    k = shtTrangTinh.Range("C" & Rows.Count).End(xlUp).Row + 1
   
    If IsArray(arrID) Then
        Dim strNoiChuoi As String
        strNoiChuoi = arrID(1, 1)
        For r = 2 To UBound(arrID)
            strNoiChuoi = strNoiChuoi & ";" & arrID(r, 1)
        Next
        shtTrangTinh.Range("C" & k).Value = strNoiChuoi
    Else
        shtTrangTinh.Range("C" & k).Value = arrID
    End If
   
    shtTrangTinh.Range("C" & k).Interior.Color = lngColor
   
    shtTrangTinh.Range("E2").Value = e + 1
    shtTrangTinh.Range("B" & e + 1).Select
End Sub

toanxn · 4/9/21

Hoàng Trọng Nghĩa đã viết:

Rất đơn giản nha bạn, không vấn đề gì đâu! Tôi làm cho bạn 4 màu, nếu muốn nhiều màu hơn thì tự bạn chèn thêm trong Select Case nhé.

PHP:

Sub IDCutting_HTN()
    Const clrBlue As Long = &HFFFF80
    Const clrGreen As Long = &HC0FFC0
    Const clrYellow As Long = &HC0FFFF
    Const clrPink As Long = &HFFC0FF
    Dim arrID
    Dim shtTrangTinh As Worksheet
    Dim e As Long, k As Long, r As Long, lngFirstRow As Long, lngColor As Long
    Set shtTrangTinh = Sheets("Trang_tính1")
    lngFirstRow = shtTrangTinh.Range("E2").Value
  
    If lngFirstRow = 0 Then
        shtTrangTinh.Range("E2").Value = 2
        lngFirstRow = 2
    End If
  
    e = shtTrangTinh.Range("B" & Rows.Count).End(xlUp).Row
    If e < lngFirstRow Then
        shtTrangTinh.Range("B" & e + 1).Select
        Exit Sub
    End If
  
    Select Case shtTrangTinh.Range("B" & lngFirstRow - 1).Interior.Color
    Case clrBlue
        lngColor = clrGreen
    Case clrGreen
        lngColor = clrYellow
    Case clrYellow
        lngColor = clrPink
    Case Else
        lngColor = clrBlue
    End Select
  
    shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Interior.Color = lngColor
  
    arrID = shtTrangTinh.Range("B" & lngFirstRow & ":B" & e).Value
    k = shtTrangTinh.Range("C" & Rows.Count).End(xlUp).Row + 1
  
    If IsArray(arrID) Then
        Dim strNoiChuoi As String
        strNoiChuoi = arrID(1, 1)
        For r = 2 To UBound(arrID)
            strNoiChuoi = strNoiChuoi & ";" & arrID(r, 1)
        Next
        shtTrangTinh.Range("C" & k).Value = strNoiChuoi
    Else
        shtTrangTinh.Range("C" & k).Value = arrID
    End If
  
    shtTrangTinh.Range("C" & k).Interior.Color = lngColor
  
    shtTrangTinh.Range("E2").Value = e + 1
    shtTrangTinh.Range("B" & e + 1).Select
End Sub

View attachment 265351

cám ơn anh! Anh phá bỏ mọi định luật của excel rồi, anh có bí kíp gì mà thành cao thủ cho em theo với!

Tạo file nhóm ngẫu nhiên mã khách hàng

Thành viên mới

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

File đính kèm

Thành viên mới

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Chuyên gia GPE

Thành viên mới