سلام
کدش سادست ولی کار راه میفته!
کد:
Sub insertcopy()
Application.ScreenUpdating = False
Dim lrow As Long
Dim countnum As Long
lrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = lrow To 1 Step -1
countnum = Application.WorksheetFunction.Count(Rows(i))
If countnum > 1 Then
Range(i + 1 & ":" & i + countnum - 1).Insert
Range(Cells(i, 2), Cells(i, countnum)).Copy
Cells(i, 1).Offset(1, 0).PasteSpecial Transpose:=True
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
علاقه مندی ها (Bookmarks)