Code cho nút "CHEN HANG" !!!

Liên hệ QC

quangthanhdu

Thành viên chính thức
Tham gia
21/5/10
Bài viết
51
Được thích
4
Mọi người giúp mình viết code cho nút "CHEN HANG", nội dung như file excel.Chân thành cảm ơn...
 

File đính kèm

Mọi người giúp mình viết code cho nút "CHEN HANG", nội dung như file excel.Chân thành cảm ơn...
Thử đại cái này xem sao, trúng trật hên xui, có gì bàn tiếp
Mã:
Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
    Dim Vung, Cll, Dk, VungDk, I
        Dk = "POLE"
        Set VungDk = Range([a2], [a500].End(xlUp)).Offset(0, 1)
        Set Vung = Range([l1], [l100].End(xlUp))
            For Each Cll In Range([a2], [a500].End(xlUp))
                I = Application.WorksheetFunction.CountA(VungDk)
                If Cll = Dk Then
                    Cll.Offset(1, 0).EntireRow.Insert
                    Cll.Offset(1, 11).Delete Shift:=xlUp
                    Cll.Offset(1, 1) = Vung(I + 1)
                End If
            Next
   Application.ScreenUpdating = True
End Sub
Cái dữ liệu ở cột L "hổng" đủ để điền vào chỗ trống
Thân
 
Upvote 0
SPAM cho ConCoGia tức chơi:

Nếu xài 1 trong 2 macro sau sẽ tiết kiệm thời gian hơn macro trên của anh
Mã:
Option Explicit
[B]Sub AddRows()[/B]
 Dim jJ As Long, eRw As Long:          Const GPE As String = "POLE"
 Dim WF, Cls As Range, Rng As Range:   Dim Timer_ As Double
 
 Timer_ = Timer
 eRw = [A65500].End(xlUp).Row:      Application.ScreenUpdating = False
 Set WF = Application.WorksheetFunction
 eRw = eRw + WF.CountIf([A1].Resize(eRw), GPE)
 For Each Cls In [a2].Resize(eRw)
   If Cls.Value = "POLE" Then
      jJ = 1 + jJ:            Set Rng = Cells(jJ, "L")
      With Cls.Offset(1)
         .EntireRow.Insert
         .Offset(-1, 1).Value = IIf(Rng.Value <> "", Rng.Value, "GPE " & jJ)
      End With
   End If
 Next Cls
 [E65500].End(xlUp).Offset(1).Value = Timer - Timer_
End Sub
PHP:
Sub TimVaThemDong()
 Dim jJ As Long, eRw As Long:                         Const GPE As String = "POLE"
 Dim WF, Cls As Range, Rng As Range, sRng As Range:
 Dim Timer_ As Double, MyAdd As String
 
 Timer_ = Timer:           Application.ScreenUpdating = False
 Set Rng = Range([A1], [A65500].End(xlUp))
 Set Cls = Rng.Find(GPE, , xlFormulas, xlWhole)
 If Not Cls Is Nothing Then
   MyAdd = Cls.Address
   Do
      jJ = jJ + 1:            Set sRng = Cells(jJ, "L")
      With Cls.Offset(1)
         .EntireRow.Insert
         .Offset(-1, 1).Value = IIf(sRng.Value <> "", sRng.Value, "GPE " & jJ)
      End With
      Set Cls = Rng.FindNext(Cls)
   Loop While Not Cls Is Nothing And Cls.Address <> MyAdd
 End If
 [H65500].End(xlUp).Offset(1).Value = Timer - Timer_
End Sub
 
Upvote 0
Dùng AutoFilter cho nó bảnh:
PHP:
Private Sub CommandButton1_Click()
  Dim TmpRng As Range
  Application.ScreenUpdating = False
  With Range([A1], [A65536].End(xlUp))
    .AutoFilter 1, "POLE"
    Set TmpRng = Intersect(.Cells, .Offset(1)).SpecialCells(12)
    .AutoFilter
    TmpRng.Offset(1).Insert 2
    TmpRng.Offset(1, 1) = "=INDIRECT(""L""&COUNTIF(R1C1:RC1,""POLE""))"
    .Offset(, 1).Value = .Offset(, 1).Value
  End With
  Application.ScreenUpdating = True
End Sub
Ẹc... Ẹc... hổng có vòng lập nào
 

File đính kèm

Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom