[發問] 如何加插行數

donod

附件中，G至J欄，當K欄(間距)的絕對值小於儲存格M4及大於儲存格L4，都自動向下加插行數，將每行間距(J欄)都變為以M4中的設定，間距會是遞增或遞減
綠色部分是用人手加插，請教大大，VBA如何寫才可做到這效果，謝謝!

TEST1.rar (388.53 KB)

下載次數: 1

2019-7-7 15:27

donod

用這個會更好，希望各版大，先進們可指教，謝謝!

TEST2.rar (389.07 KB)

下載次數: 2

2019-7-7 17:53

donod

找了關於"插入"的文章，以下還是達不到效果，因為要處理數據很多，無法人手處理，希望大大出手相助，再謝謝!

謝謝GBKEE版大的提供
http://forum.twbts.com/viewthrea ... ighlight=%B4%A1%A4J
工作表上的預設事件(儲存格有改變所觸動事件)

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Dim Rng As Range
   
4.     Set Rng = Range("C45:H50")   '指定插入新的一列的範圍
   
5.    
   
6.     If Target.Columns.Count = Rng.Columns.Count Then
   
7.         'Columns.Count:傳回範圍內欄位的總數
   
8.         'Rows.Count:傳回範圍內列位的總數
   
9.         If Not Intersect(Rng, Target) Is Nothing And Target.Rows.Count = 1 Then
   
10.         'Intersect 方法 傳回  ***[Range 物件]***，此物件代表兩個或多個範圍重疊的矩形範圍。
    
11.         ' Target.Rows.Count = 1  '一列的範圍
    
12.             If Target.Cells(1).Column = Rng.Cells(1).Column And Target.Cells(Target.Cells.Count).Column = Rng.Cells(Rng.Cells.Count).Column Then
    
13.                 'Target.Cells(1).Column = Rng.Cells(1).Column
    
14.                 '插入新的一列的第一個欄號=指定插入新的一列的範圍的第一個欄號
    
15.                 'Target.Cells(Target.Cells.Count).Column = Rng.Cells(Rng.Cells.Count).Column
    
16.                 '插入新的一列的最後一個欄號 = 指定插入新的一列的範圍的最後一個欄號
    
17.                 MsgBox Target.Address
    
18.             End If
    
19.         End If
    
20.     End If
    
21. End Sub

複製代碼

http://forum.twbts.com/viewthread.php?tid=21219&highlight=%B4%A1%A4J

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim A As Range, B As Variant, i As Integer
   
4.     For Each A In Range("A1", Range("A1").End(xlDown))  'A1 往下到最後一筆資料
   
5.         B = ""
   
6.         For i = 1 To Len(A)
   
7.             If Mid(A, i, 1) Like "[A-Z]" Then B = IIf(B = "", Mid(A, i, 1), B & "," & Mid(A, i, 1))
   
8.             '找到大寫的字母 導入變數
   
9.         Next
   
10.         If B <> "" Then        '有找到大寫的字母
    
11.             B = Split(B, ",")  '找到大寫字母的陣列
    
12.             For i = 0 To UBound(B)
    
13.                 A = Replace(A, B(i), " " & B(i))  '加入空格
    
14.             Next
    
15.             Do While InStr(A, Space(2))         '包含有兩格的空白字元
    
16.                 A = Replace(A, Space(2), Space(1))  '消除 兩格的空白字元 為一格的空白字元
    
17.             Loop
    
18.         End If
    
19.     Next
    
20. End Sub

複製代碼

donod

還未成功，再請各位大大相助，再謝謝!

donod

請問大大這個如何修改，才可做到要求。謝謝!

1. Private Sub Command173_Click()
   
2. Dim x3 As Integer
   
3. x3 = [A65536].End(xlUp).Row
   
4. For I = 1 To x3
   
5. Do While I1 < 12
   
6. Rows(I ＋ 1 ＋ i2).Insert
   
7. I1 = I1 ＋ 1
   
8. Loop
   
9. i2 = i2 ＋ I1
   
10. I1 = 0
    
11. Next
    
12. End Sub

複製代碼

donod

G至J欄，當K欄(間距)的絕對值小於儲存格M4及大於儲存格L4，都自動向下加插行數，將每行間距(J欄)都變為以N4中的設定，間距會是遞增或遞減
綠色部分是用人手加插，請教大大，VBA如何寫才可做到這效果，謝謝!

donod

再找了這個參考
http://forum.twbts.com/thread-6131-1-1.html

1. Sub FF()
   
2. LastR = [A65536].End(xlUp).Row
   
3. For R = LastR To 1 Step -1
   
4.   If Cells(R, 1) Like "po*" Then
   
5.      Cells(R + 1, 1).Insert Shift:=xlDown
   
6.      Cells(R, 2).Copy Cells(R + 1, 1)
   
7.   End If
   
8. Next R
   
9. [B:B] = ""
   
10. End Sub

複製代碼

donod

復制並插入特定的行
https://www.extendoffice.com/zh-TW/documents/excel/3682-excel-copy-and-insert-row-multiple-times.html

1. Sub test()
   
2. 'Updateby Extendoffice 20160616
   
3.     Dim xCount As Integer
   
4. LableNumber:
   
5.     xCount = Application.InputBox("Number of Rows", "Kutools for Excel", , , , , , 1)
   
6.     If xCount < 1 Then
   
7.         MsgBox "the entered number of rows is error, please enter again", vbInformation, "Kutools for Excel"
   
8.         GoTo LableNumber
   
9.     End If
   
10.     ActiveCell.EntireRow.Copy
    
11.     Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(xCount, 0)).EntireRow.Insert Shift:=xlDown
    
12.     Application.CutCopyMode = False
    
13. End Sub

複製代碼

donod

網上找到這個
https://blog.51cto.com/hoenix/461350
"要把不连续的时段补充连续"

1. Sub Macro1()
   
2. For i = 2 To 5000 Step 1
   
3. If Cells(i, 2) + 2 = Cells(i + 1, 2) Then  //cell(a,b) a为行，b为列
   
4. Rows(i + 1).Insert
   
5. Cells(i + 1, 2) = Cells(i, 2) + 1
   
6. End If
   
7. Next i
   
8. End Sub

複製代碼

donod

小輩才疏學淺，以上多個參考如何整合，希望先進們幫助，謝謝!