Xin chỉ giúp VBA hoặc công thức chèn dòng có điều kiện

[hoangocgiang]

Xin các bác giúp em với ạ. Chèn dòng theo điều kiện ở cột A trong file bằng VBA hoặc bằng công thức đều được ạ. Xin đa tạ.

 

[BuiQuangThuan]

Xin các bác giúp em với ạ. Chèn dòng theo điều kiện ở cột A trong file bằng VBA hoặc bằng công thức đều được ạ. Xin đa tạ.

Sao mình cố gắng đọc rồi mà không hiểu nhỉ

 

[VetMini]

Sao mình cố gắng đọc rồi mà không hiểu nhỉ

A3 cho biết có bao nhiêu dòng cần thêm giữa B3 và B2.
B2=1; B3=2. Liên tục, như vậy chẳng cần thêm gì. Và A3=0
B3=2; B4=4. Cần thêm 3 ở giữa. Và A4=1

Tôi cũng chả hiểu cột A cho sẵn hay cần tính. Nếu cần tính thì:
A3=B3-B2-1

Bên cột C thì dùng hàm Sequence.
. Tham thứ nhất là số dòng: Max(cột B) - Min(cột B) + 1
. Tham thứ hai là số cột: 1
. Tham thứ ba là số bắt đầu: Min(cột B)
. Tham thứ tư là bước: 1

Nếu phiên bản không có hàm Sequence thì dùng hàm row.


@thớt: từ "đa tạ" thuộc về thế kỷ 19. Dùng "cảm ơn" dễ nghe hơn.

 

[HieuCD]

Sao mình cố gắng đọc rồi mà không hiểu nhỉ

Không hiểu do cột A nhập số không khớp với cột B

 

[SA_DQ]

Đề bài

Kết quả

1​

1​

0​

2​

2​

A3=0 vì B2 +1 =B3

1​

4​

3​

B4 = 1 vì B3 phải cộng thêm 1 + 1 mới thành B4

2​

7​

4​

B5=2 vì B4 phải cộng thêm 1 +2 mới thành B5

2​

10​

5​

Cũng vậy vì B5 + 1 + 2 => 10 (B6)

0​

11​

6​

0​

12​

7​

2​

14​

8​

3​

18​

9​

3​

21​

10​

...

11​

12​

13​

14​

15​

16​

17​

18​

19​

20​

21​

Thực ra [B1] không phải là cột kết quả mà là cột bên phải của nó;
Cột B đang là những con số cho trước;
Cột A là số dòng cần thêm để cột C có những con số tăng dần đều (bước nhảy = 1)

 

[HeSanbi]

@hoangocgiang
Bạn gõ vào ô B2 công thức: =IF(ISNUMBER(A2),A2+B1+1,1) fill xuống cho đúng

Với từ "chèn" của bạn có hai hành động: 1 chèn giá trị đủ số dòng, 2 chèn dòng bảng tính

Trong excel mới bạn có thể sử dụng C2=SEQUENCE(SUM(A3:A1000)+COUNT(A3:A1000)+1,1)


Với VBA: C2=InsertStep(A3:A1000)

Option Explicit
Option Compare Text
Public Const ProjectUDFName = "InsertNumbering"
Public Const ProjectUDFFileName = "InsertNumbering"
Public Const projectUDFVersion = "1.0"
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
#If VBA7 Then
#Else
  Private Enum LongLong:[_]:End Enum
  #If Win64 Then
  '#ElseIf Win32 Then
  #Else
    Private Enum LongPtr:[_]:End Enum
  #End If
#End If
Public Enum AutoInsertStepSettings
  afsMainFX = 1

End Enum
Private Type TypeArguments
  XLNew As Boolean
  timer As Single
  Action As Long
  Direction As Long
  Target As Variant
  address As String
  caller As Range
  fx As String
  resultArray()  As Variant
  rowsCount  As Long
End Type

#If VBA7 Then
  Public Declare PtrSafe Function SetTimer Lib "USER32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Public Declare PtrSafe Function KillTimer Lib "USER32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Public Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Public Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private Works() As TypeArguments
'-------------------------------------------------------------------------------------------------------
Function InsertStep2()
  InsertStep2 = Array("1")
End Function
Function InsertStep(ByVal DataCells As Range) As Variant
  On Error Resume Next
  Dim r&, i&, s, z(), n As Boolean
  XLAppVersion n
  s = DataCells.address(0, 0, , 1)
  r = Evaluate("=SUM(" & s & ")+COUNT(" & s & ")+1") - n - 1
  If r > 0 Then
    ReDim z(1 To r, 1): For i = 1 To r: z(i, 1) = i - n + 1: Next
    If n Then
      InsertStep = z
    Else
      InsertStep = 1
      Call AddArgumentsInsertStep(afsMainFX, z, r, n)
    End If
  Else
    If n Then
      InsertStep = Array("")
    Else
      InsertStep = ""
      Call AddArgumentsInsertStep(afsMainFX, 0, 0, n)
    End If
  End If
End Function

Private Function AddArgumentsInsertStep(Direction%, ParamArray arguments())
  On Error Resume Next

  Dim k%, i%, j%, r As Object, s$, f$, w As TypeArguments, n As Boolean
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function

  If r.Worksheet.ProtectContents = True Then AddArgumentsInsertStep = "[SheetProtected]": Exit Function
 
  If n Then f = r.Formula2 Else f = r.Formula
  If Not f Like "*InsertStep(*" Then Exit Function
  s = r.address(0, 0, , 1)
  k = UBound(Works):
'  If k > 0 Then
'    For i = 1 To k
'      With Works(i)
'        If s = .address And f = .fx Then
'          Select Case .Action
'          Case 1: k = i: GoTo s
'          Case 2: Exit Function
'          Case 3:
'            If Direction = afsMainFX Then
'              .Action = 4: AddArgumentsInsertStep = .resultArray: Call SetTimer(Application.Hwnd, 241112, 0, AddressOf InsertStepA_callback)
'            End If
'            Exit Function
'          End Select
'          Exit For
'        End If
'      End With
'    Next
'  End If
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k):  .Action = 1:  .Direction = 0: Set .caller = r: .address = s: .fx = f:
    Select Case Direction
    Case afsMainFX:  .resultArray = arguments(0): .rowsCount = arguments(1): .XLNew = arguments(2):
      .Direction = Direction
      InsertStepSetTimer
    End Select
  End With
End Function

''///////////////////////////////////////////////////////
Private Sub InsertStepSetTimer()
  Call SetTimer(Application.Hwnd, 241111, 0, AddressOf InsertStepA_callback)
End Sub

Private Sub InsertStepA_callback(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal nIDEvent As LongPtr, ByVal dwTimer As LongPtr)
  On Error Resume Next
  Call KillTimer(Hwnd, nIDEvent)
  Select Case nIDEvent
  Case 241111: InsertStepA_working
  Case 241112:
    Dim k%, i%, j%
    k = UBound(Works):
    For i = 1 To k
      If Works(i).Action = 4 Then j = j + 1: Debug.Print j; k
    Next
    If j = k Then Erase Works
  End Select
End Sub

Private Sub InsertStepA_working()
  On Error Resume Next
  Dim s$
  Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, lr&, cfl%, su As Boolean, ac As Boolean, ee As Boolean, v As Variant, z()
  ub = UBound(Works)
  For i = 1 To ub
    b = Works(i)
    If b.Action <> 1 Then GoTo n
    If a Is Nothing Then
      Set a = Application
      su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
      ee = a.EnableEvents: If ee Then a.EnableEvents = False
      ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
    End If
    Select Case b.Direction
    Case afsMainFX: AreaClearContents b.caller(2, 1)
      lr = b.rowsCount
      v = b.resultArray
      Err.Clear
      If lr > 0 Then
        ReDim z(1 To lr, 1)
        For k = 1 To lr
          b.caller(1 + k, 1) = k + 1
        Next
      End If
     
    End Select
n:
  Next
E:
  Erase Works
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
    If ac And xlCalculationAutomatic <> a.Calculation Then a.Calculation = ac
    Set a = Nothing
  End If
End Sub

Function XLAppVersion(Optional newVersion As Boolean, Optional implicitIntersectionOperator$, Optional SpillOperator$) As Long
  Static n&, v&, i1$, i2$
  If n <> 0 Then XLAppVersion = v: newVersion = n = 1: implicitIntersectionOperator = i1: SpillOperator = i2: Exit Function
  Dim registryObject As Object
  Dim rootDirectory$
  Dim keyPath$
  Dim arrEntryNames As Variant
  Dim arrValueTypes As Variant
  Dim x&
  Select Case Val(Application.Version)
  Case Is = 16
    'Check for existence of Licensing key
    i1 = "@"
    keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
    rootDirectory = "."
    Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
    registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
    On Error GoTo ErrorExit
    For x = 0 To UBound(arrEntryNames)
      If InStr(arrEntryNames(x), "365") > 0 Then n = 1: v = 365: Exit For
      If InStr(arrEntryNames(x), "2019") > 0 Then
        If Application.Build >= 14332 Then
          'ProductCode: {90160000-000F-0000-1000-0000000FF1CE}
          'CalculationVersion:  191029
          n = 1: i2 = "#": v = 2021
        Else
          n = -1: v = 2019
        End If
        Exit For
      End If
      If InStr(arrEntryNames(x), "2016") > 0 Then v = 2016: n = -1: Exit For
    Next x
  Case Is = 15: n = -1: v = 2013
  Case Is = 14: n = -1: v = 2010 'ProductCode: {91140000-0011-0000-1000-0000000FF1CE} 'CalculationVersion:  145621
  Case Is = 12: n = -1: v = 2007
  Case Else: n = -1: v = 0
  End Select
  newVersion = n = 1: XLAppVersion = v: implicitIntersectionOperator = i1: SpillOperator = i2
Exit Function
ErrorExit:
  'Version 16, but no licensing key. Must be Office 2016
  v = 2016: n = -1: XLAppVersion = v: newVersion = n = 1
End Function

Private Sub AreaClearContents(ByVal vRange As Object, Optional ByVal OffsetRow&, Optional ByVal OffsetColumn&, Optional LimitRow&, Optional LimitColumn&)
  Dim r As Object
  Set r = AreaFromTarget(vRange, OffsetRow&, OffsetColumn&, LimitRow, LimitColumn)
  If Not r Is Nothing Then r.ClearContents
End Sub
Private Function AreaFromTarget(ByVal vRange As Object, Optional ByVal OffsetRow&, Optional ByVal OffsetColumn&, Optional LimitRow&, Optional LimitColumn&) As Object
  Dim r As Range, T As Range, R1&, C1&, R2&, C2&
  R1 = OffsetRow: C1 = OffsetColumn: Set r = vRange(1, 1): Set T = r.CurrentRegion
  If T.Cells.Count > 1 Then
    R2 = T.Row + T.Rows.Count - r.Row - R1 + 1
    C2 = T.Column + T.Columns.Count - r.Column - C1 + 1
    If LimitRow > 0 Then R2 = IIf(LimitRow < R2, LimitRow, R2)
    If LimitColumn > 0 Then C2 = IIf(LimitColumn < C2, LimitColumn, C2)
    If R2 > 1 And C2 > 1 Then Set AreaFromTarget = r(R1 + 1, C1 + 1).Resize(R2, C2)
  End If
End Function

 

[VetMini]

Thực ra [B1] không phải là cột kết quả mà là cột bên phải của nó;
Cột B đang là những con số cho trước;
Cột A là số dòng cần thêm để cột C có những con số tăng dần đều (bước nhảy = 1)

File của thớt có cái vụ merged cells cho nên coi dễ lầm.
Bài #4 nói "không khớp" là vì dòng cuối cột A tính không đúng: 21-18-1 = 2 (trong file dữ liệu là 3)

 

[bebo021999]

Rốt cuộc thì con voi nó hình dạng thế nào ạ?
Giống cột nhà, hay cái chổi, hay cái quạt mo?

 

[VetMini]

Rốt cuộc thì con voi nó hình dạng thế nào ạ?
Giống cột nhà, hay cái chổi, hay cái quạt mo?

Nó giống bát tiết chó.
Húp vào miệng mới biết nó có bao nhiêu gan, tim, phèo,...
Rất tiếc là thớt không phân biệt được gừng và riềng cho nên dọn nhầm.

 

[SA_DQ]

Nó giống bát tiết chó.
Húp vào miệng mới biết nó có . . . . . . . bao nhiêu gan, tim, phèo,...
Rất tiếc là thớt không phân biệt được gừng và riềng cho nên dọn nhầm.

Mới đọc nữa bài của bác mình liền với tay đến xị rượu & làm 1 ngụm với mồi ảo, thiệc ngon lành!

 

[VetMini]

Mới đọc nữa bài của bác mình liền với tay đến xị rượu & làm 1 ngụm với mồi ảo, thiệc ngon lành!

Thỉ nó vốn là đơn giản, đế mắt mèo hay đế ngang, thậm chí bia cũng đưa tuốt.
Thế mà vẫn có người đưa nguyên chai Hennessy XO. Ba cái đồ hạng gộc này nó làm mất cả hứng chắp nước chưn (tiết).

 

[hoangocgiang]

File của thớt có cái vụ merged cells cho nên coi dễ lầm.
Bài #4 nói "không khớp" là vì dòng cuối cột A tính không đúng: 21-18-1 = 2 (trong file dữ liệu là 3)

Đúng rồi ạ. Em tách Đề bài và Kết quả ở 2 sheet như này dễ hình dung hơn ạ.

 

[hoangocgiang]

Chèn thêm dòng đúng với số cho sẵn ở cột A thôi ạ. Xin các bác giúp cho ạ.

 

[TongDe]

Chắc là cái quạt mo rồi...
Thử làm thầy bói mù nha!
Chủ thớt định tạo danh sách để merge vào label
Nếu đúng thì tham khảo file attach nha

 

[ngocbaovu]

Chèn thêm dòng đúng với số cho sẵn ở cột A thôi ạ. Xin các bác giúp cho ạ.

Bạn thử chạy code này xem

Sub Chendong()
    Dim ws As Worksheet
    Dim rg As Range
    Dim lr, i, j As Long
    Dim c As Variant
    
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set rg = ws.Range("A1:A" & lr)
  
    For i = lr To 2 Step -1
        c = rg.Cells(i).Value
        If IsNumeric(c) And c > 0 Then
            For j = 1 To c
                rg.Cells(i).EntireRow.Insert xlShiftDown
            Next j
        End If
    Next i
    MsgBox "OK! Xong!"
End Sub