Thêm số lượng số đơn vào sheet bằng VBA

Liên hệ QC
M

Minhtruc94

Thành viên mới
Tham gia
28/12/21
Bài viết
6
Được thích
1
Sub ABC()
Dim Arr(), iR&, WS As Worksheet
Dim dic As Object, s, X
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("scripting.dictionary")
For Each WS In Worksheets
If WS.Name <> "data" Then
WS.Delete
End If
Next
With Sheets("data")
If .AutoFilterMode Then .AutoFilterMode = False
Arr = .Range("C2:C" & .Range("C" & Rows.Count).End(3).Row).Value
End With
For i = 1 To UBound(Arr, 1)
If dic.exists(Arr(i, 1)) = False Then
dic.Add (Arr(i, 1)), ""
End If
Next
iR = Sheets("data").Range("C" & Rows.Count).End(3).Row
For Each s In dic.keys
With Sheets("data")
Worksheets.Add After:=Worksheets(Worksheets.Count)
.Range("$A$1:$H" & iR).AutoFilter 3, s
.Range("$A$1:$H" & iR).Copy ActiveSheet.Range("A1")
s = Replace(s, "/", "-")
ActiveSheet.Name = Right(s, Len(s) - 7)
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("data").Select
Range("F572").Select
Selection.AutoFilter
End Sub

xin chào mọi người , mình có đoạn code tách sheet theo tên của cột C nhưng giờ mình muốn thêm số lượng đơn từ trong nội dung
ví dụ : Sheet Phu Nhuan-Phuong 4 LM Hub_6 (số lượng đơn) ( số dòng trừ tiêu đề sheet ) để khi ra file có số lượng đơn , nhờ mọi người hỗ trợ với , mình cảm ơn
 

File đính kèm

  • Tạo tool update V2 .xlsm
    3 MB · Đọc: 20
Minhtruc94 đã viết:
Sub ABC()
Dim Arr(), iR&, WS As Worksheet
Dim dic As Object, s, X
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("scripting.dictionary")
For Each WS In Worksheets
If WS.Name <> "data" Then
WS.Delete
End If
Next
With Sheets("data")
If .AutoFilterMode Then .AutoFilterMode = False
Arr = .Range("C2:C" & .Range("C" & Rows.Count).End(3).Row).Value
End With
For i = 1 To UBound(Arr, 1)
If dic.exists(Arr(i, 1)) = False Then
dic.Add (Arr(i, 1)), ""
End If
Next
iR = Sheets("data").Range("C" & Rows.Count).End(3).Row
For Each s In dic.keys
With Sheets("data")
Worksheets.Add After:=Worksheets(Worksheets.Count)
.Range("$A$1:$H" & iR).AutoFilter 3, s
.Range("$A$1:$H" & iR).Copy ActiveSheet.Range("A1")
s = Replace(s, "/", "-")
ActiveSheet.Name = Right(s, Len(s) - 7)
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("data").Select
Range("F572").Select
Selection.AutoFilter
End Sub

xin chào mọi người , mình có đoạn code tách sheet theo tên của cột C nhưng giờ mình muốn thêm số lượng đơn từ trong nội dung
ví dụ : Sheet Phu Nhuan-Phuong 4 LM Hub_6 (số lượng đơn) ( số dòng trừ tiêu đề sheet ) để khi ra file có số lượng đơn , nhờ mọi người hỗ trợ với , mình cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn thử thay code dưới đây vào sub ABC và sub xoasheethangloat và chay thử xem sao. Vẫn code của bạn tôi chỉ mạn phép tác giả thay đổi tý chút thôi. Neus có gì không phải xin được cảm thông.
Do tên Sh dài quá 30 ký tự nên tôi buộc phải bỏ bớt phần "LM Hub".
Hy vọng là đúng ý bạn.
Mã: 
Sub ABC()
    Dim Arr(), KQ(), iR&, WS As Worksheet
    Dim dic As Object, s, X, k&, Key
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("scripting.dictionary")
For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
With Sheets("data")
    If .AutoFilterMode Then .AutoFilterMode = False
    iR = Sheets("data").Range("C" & Rows.Count).End(3).Row
    Arr = .Range("A2:H" & iR).Value
End With
For i = 1 To UBound(Arr)
    If dic.Exists(Arr(i, 3)) = False Then
        t = t + 1: dic.Add (Arr(i, 3)), t
    End If
Next
For Each s In dic.keys
    With Sheets("data")
    k = 0
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(k, j) = Arr(i, j)
                    Next j
                End If
            Next i
    
            ActiveSheet.Range("A1").Resize(k, UBound(Arr, 2)) = KQ
Erase KQ

        '.Range("$A$1:$H" & iR).AutoFilter 3, s
        '.Range("$A$1:$H" & iR).Copy ActiveSheet.Range("A1")
        s = Replace(s, "/", "-")
        s = Replace(s, "LM Hub", "")
        ActiveSheet.Name = Right(s, Len(s) - 7) & "_" & k
     '   k = 0
    End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Sheets("data").Select
'    Range("F572").Select
'    Selection.AutoFilter
End Sub
Sub Xoasheethangloat()
Application.DisplayAlerts = False
    Dim WS As Worksheet
    For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
Application.DisplayAlerts = True
End Sub
 
Lần chỉnh sửa cuối:
Vì số lượng thêm vào đến 3 ký tự, trong khi tên sheet max = 31, nên có trường hợp này:
"Binh Chanh/Le Minh Xuan LM Hub_100" (34 ký tự) bị lỗi
Mình bỏ "Hub_" ở cuối
Tên sheet bạn nên đặt code cho các địa phương, VD: Bình Chánh = BC, Hóc Môn =HM
để tên sheet gọn hơn

PHP: 
Sub ABC()
Dim Arr(), key, Lr&, i&, ws As Worksheet, st As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "data" Then
            ws.Delete
        End If
    Next
With Sheets("data")
    Lr = .Cells(Rows.Count, "C").End(xlUp).Row
    If .AutoFilterMode Then .AutoFilterMode = False
        Arr = .Range("C2:C" & Lr).Value
        For i = 1 To UBound(Arr, 1)
            If dic.exists(Arr(i, 1)) = False Then
                dic.Add (Arr(i, 1)), ""
            End If
        Next
            For Each key In dic.keys
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                .Range("$A$1:$H" & Lr).AutoFilter 3, key
                .Range("$A$1:$H" & Lr).Copy ActiveSheet.Range("A1")
                ' Vi sheet name vuot qua 31 ky tu nen bo bot chu "HUB" o cuoi
                st = Replace(Replace(key, "/", "-"), " Hub", WorksheetFunction.CountIf(.Range("C2:C" & Lr), key))
                ActiveSheet.Name = Right(st, Len(st) - 7)
            Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("data").Select
    Range("F572").Select
    Selection.AutoFilter
End Sub
 
bebo021999 đã viết:
Sub ABC() Dim Arr(), key, Lr&, i&, ws As Worksheet, st As String Dim dic As Object Set dic = CreateObject("scripting.dictionary") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Worksheets If ws.Name <> "data" Then ws.Delete End If Next With Sheets("data") Lr = .Cells(Rows.Count, "C").End(xlUp).Row If .AutoFilterMode Then .AutoFilterMode = False Arr = .Range("C2:C" & Lr).Value For i = 1 To UBound(Arr, 1) If dic.exists(Arr(i, 1)) = False Then dic.Add (Arr(i, 1)), "" End If Next For Each key In dic.keys Worksheets.Add After:=Worksheets(Worksheets.Count) .Range("$A$1:$H" & Lr).AutoFilter 3, key .Range("$A$1:$H" & Lr).Copy ActiveSheet.Range("A1") ' Vi sheet name vuot qua 31 ky tu nen bo bot chu "HUB" o cuoi st = Replace(Replace(key, "/", "-"), " Hub", WorksheetFunction.CountIf(.Range("C2:C" & Lr), key)) ActiveSheet.Name = Right(st, Len(st) - 7) Next End With Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("data").Select Range("F572").Select Selection.AutoFilter End Sub
Nhấp chuột vào đây để mở rộng...
Đúng ý e rồi a , cảm ơn a nhiều
 
HUONGHCKT đã viết:
Bạn thử thay code dưới đây vào sub ABC và sub xoasheethangloat và chay thử xem sao. Vẫn code của bạn tôi chỉ mạn phép tác giả thay đổi tý chút thôi. Neus có gì không phải xin được cảm thông.
Do tên Sh dài quá 30 ký tự nên tôi buộc phải bỏ bớt phần "LM Hub".
Hy vọng là đúng ý bạn.
Mã: 
Sub ABC()
    Dim Arr(), KQ(), iR&, WS As Worksheet
    Dim dic As Object, s, X, k&, Key
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("scripting.dictionary")
For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
With Sheets("data")
    If .AutoFilterMode Then .AutoFilterMode = False
    iR = Sheets("data").Range("C" & Rows.Count).End(3).Row
    Arr = .Range("A2:H" & iR).Value
End With
For i = 1 To UBound(Arr)
    If dic.Exists(Arr(i, 3)) = False Then
        t = t + 1: dic.Add (Arr(i, 3)), t
    End If
Next
For Each s In dic.keys
    With Sheets("data")
    k = 0
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(k, j) = Arr(i, j)
                    Next j
                End If
            Next i
   
            ActiveSheet.Range("A1").Resize(k, UBound(Arr, 2)) = KQ
Erase KQ

        '.Range("$A$1:$H" & iR).AutoFilter 3, s
        '.Range("$A$1:$H" & iR).Copy ActiveSheet.Range("A1")
        s = Replace(s, "/", "-")
        s = Replace(s, "LM Hub", "")
        ActiveSheet.Name = Right(s, Len(s) - 7) & "_" & k
     '   k = 0
    End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Sheets("data").Select
'    Range("F572").Select
'    Selection.AutoFilter
End Sub
Sub Xoasheethangloat()
Application.DisplayAlerts = False
    Dim WS As Worksheet
    For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
cảm ơn a , cái này chạy quá nhanh luôn , cảm ơn nhiều ạ
 
HUONGHCKT đã viết:
Bạn thử thay code dưới đây vào sub ABC và sub xoasheethangloat và chay thử xem sao. Vẫn code của bạn tôi chỉ mạn phép tác giả thay đổi tý chút thôi. Neus có gì không phải xin được cảm thông.
Do tên Sh dài quá 30 ký tự nên tôi buộc phải bỏ bớt phần "LM Hub".
Hy vọng là đúng ý bạn.
Mã: 
Sub ABC()
    Dim Arr(), KQ(), iR&, WS As Worksheet
    Dim dic As Object, s, X, k&, Key
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("scripting.dictionary")
For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
With Sheets("data")
    If .AutoFilterMode Then .AutoFilterMode = False
    iR = Sheets("data").Range("C" & Rows.Count).End(3).Row
    Arr = .Range("A2:H" & iR).Value
End With
For i = 1 To UBound(Arr)
    If dic.Exists(Arr(i, 3)) = False Then
        t = t + 1: dic.Add (Arr(i, 3)), t
    End If
Next
For Each s In dic.keys
    With Sheets("data")
    k = 0
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(k, j) = Arr(i, j)
                    Next j
                End If
            Next i
   
            ActiveSheet.Range("A1").Resize(k, UBound(Arr, 2)) = KQ
Erase KQ

        '.Range("$A$1:$H" & iR).AutoFilter 3, s
        '.Range("$A$1:$H" & iR).Copy ActiveSheet.Range("A1")
        s = Replace(s, "/", "-")
        s = Replace(s, "LM Hub", "")
        ActiveSheet.Name = Right(s, Len(s) - 7) & "_" & k
     '   k = 0
    End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Sheets("data").Select
'    Range("F572").Select
'    Selection.AutoFilter
End Sub
Sub Xoasheethangloat()
Application.DisplayAlerts = False
    Dim WS As Worksheet
    For Each WS In Worksheets
    If WS.Name <> "data" Then
        WS.Delete
    End If
Next
Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
Hi a , có thể thêm hàng tiêu đề lên không ạ , sheet bị thiếu hàng tiêu đề
 
Minhtruc94 đã viết:
Hi a , có thể thêm hàng tiêu đề lên không ạ , sheet bị thiếu hàng tiêu đề
Nhấp chuột vào đây để mở rộng...
Bạn thay dòng này
Mã: 
Arr = .Range("A2:H" & iR).Value
thành
Mã: 
Arr = .Range("A1:H" & iR).Value
và
Mã: 
 With Sheets("data")
    k = 0
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(k, j) = Arr(i, j)
                    Next j
thành
Mã: 
 With Sheets("data")
    k = 1
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(1, j) = Arr(1, j)
                        KQ(k, j) = Arr(i, j)
                    Next j

tất cả đều ở Sub ABC
 
HUONGHCKT đã viết:
Bạn thay dòng này
Mã: 
Arr = .Range("A2:H" & iR).Value
thành
Mã: 
Arr = .Range("A1:H" & iR).Value
và
Mã: 
 With Sheets("data")
    k = 0
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(k, j) = Arr(i, j)
                    Next j
thành
Mã: 
 With Sheets("data")
    k = 1
    ReDim KQ(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
        Worksheets.Add After:=Worksheets(Worksheets.Count)
           For i = 1 To UBound(Arr)
                If Arr(i, 3) = s Then
                    k = k + 1
                    For j = 1 To UBound(Arr, 2)
                        KQ(1, j) = Arr(1, j)
                        KQ(k, j) = Arr(i, j)
                    Next j

tất cả đều ở Sub ABC
Nhấp chuột vào đây để mở rộng...
e đã chỉnh nó đã có dòng tiêu đề , nhưng số hàng nó cũng tính luôn dòng tiêu đề
 
Minhtruc94 đã viết:
e đã chỉnh nó đã có dòng tiêu đề , nhưng số hàng nó cũng tính luôn dòng tiêu đề
Nhấp chuột vào đây để mở rộng...
Nghĩa là thế nào? thừa dòng hay thiếu dữ liệu? và thừa hay thiếu bao nhiêu dòng?
Nếu thừa hoặc thiếu thì bạn xem lại chỉ số k ở dòng code này và tự điều chỉnh nhé.
ActiveSheet.Range("A1").Resize(k, UBound(Arr, 2)) = KQ
Nếu thừa 1 hoặc n dòng mà ra là #N/A thì bạn .....Resize(k-1(hoặc n),...
nếu thiếu 1 hoặc n dòng thì ......Resize(k+1(hoặc n),.....
 
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
3 4 5
Trả lời
84
Đọc
2K
ptm0412
ptm0412
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
26
Đọc
666
VetMini
V
P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
4
Đọc
208
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
82
CHAOQUAY
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
13
Đọc
313
ongke0711
ongke0711
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