Option Explicit: Option Base 1 [b]
Sub CopyToRow() [/b]
Dim MRng(30)
Dim Rng As Range
Dim StrC As String, lRow As Long, iJ As Integer
Sheets("S1").Select
For Each Rng In Range("B2:X2")
lRow = 1 + lRow: MRng(lRow) = Rng.Value
Next Rng
[color="Blue"]' 'B2:X2' - là vùng nguồn để chép. [/color]
Sheets("D119").Select: lRow = 9
Do
lRow = 1 + lRow: StrC = "A" & CStr(lRow)
Range(StrC).Select:
With Selection
If Len(.Value) < 1 Then Exit Do
If .Value <> .Offset(-1, 0).Value Then
.EntireRow.Insert
For Each Rng In Range("B" & CStr(lRow) & ":X" & CStr(lRow))
iJ = iJ + 1
Rng.Value = MRng(iJ)
Next Rng
lRow = lRow + 1: iJ = 0
End If
End With
Loop [b]
End Sub [/b]
/)/hiều dòng là bi nhiêu dòng zậy?!
Option Explicit
Public Sub InsertCell()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim TLoi
TLoi = MsgBox("Ban co muon tao backup du lieu trong sheet hien hanh khong?", vbInformation + vbYesNo)
If TLoi = vbYes Then ActiveSheet.Copy Before:=ActiveSheet
Dim shtName As Worksheet
Set shtName = ActiveSheet
'Khoi tao gia tri bien i de xac dinh dong dau tien trong khoi du lieu
i = InputBox("Nhap dong du lieu dau tien trong vung du lieu can Insert", , 9)
If Err.Number <> 0 Then Exit Sub
Do
i = i + 1
If Cells(i, "A") <> Cells(i - 1, "A") And Not IsEmpty(Cells(i - 1, "A")) Then
Rows(i & ":" & i + 5).Select
Selection.Insert Shift:=xlDown
'Copy 6 dong
Sheets("Sheet1").Select
Range("A2:W8").Select
Selection.Copy
shtName.Select
Cells(i, "A").Select
ActiveSheet.Paste
i = i + 5
End If
Loop While i <= (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
