Board logo

標題: [發問] 如何加插行數 [打印本頁]
作者: donod    時間: 2019-7-7 15:27     標題: 如何加插行數

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

[attach]31001[/attach]
作者: donod    時間: 2019-7-7 17:57

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

[attach]31002[/attach]
作者: donod    時間: 2019-7-8 13:30

本帖最後由 donod 於 2019-7-8 13:31 編輯

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

謝謝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    時間: 2019-7-9 16:54

還未成功，再請各位大大相助，再謝謝!
作者: donod    時間: 2019-7-10 16:59

請問大大這個如何修改，才可做到要求。謝謝!
  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    時間: 2019-7-10 17:52

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

再找了這個參考
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    時間: 2019-7-10 23:52

復制並插入特定的行
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    時間: 2019-7-11 00:26

網上找到這個
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    時間: 2019-7-11 00:38

小輩才疏學淺，以上多個參考如何整合，希望先進們幫助，謝謝!
作者: 准提部林    時間: 2019-7-11 09:41

應該沒人看得懂邏輯~~
做一張原表,
及一張結果表, 並說明規則流程,
這樣也許可以比對~~
作者: donod    時間: 2019-7-11 10:53

本帖最後由 donod 於 2019-7-11 10:57 編輯

回復 11# 准提部林
請准提部林大大指教，謝謝!
G至J欄，當K欄(間距)的絕對值小於儲存格M4及大於儲存格L4，都自動向下加插行數，將每行間距(J欄)都變為以N4中的設定，間距會是遞增或遞減
[attach]31015[/attach]
作者: 准提部林    時間: 2019-7-11 15:14

Sub TEST()
Dim xE As Range, i&, j&, Num(2), xR As Range, U(3), UK&
Num(0) = [N4]: Num(1) = [L4]: Num(2) = [M4]
Set xE = Cells(Rows.Count, "G").End(xlUp)
For i = xE.Row To 6 Step -1
    Set xR = Cells(i - 1, "G")
    U(1) = xR(2, 4):  U(2) = xR(1, 4):  U(0) = U(1) - U(2)
    If Abs(U(0)) <= Num(1) Or Abs(U(0)) >= Num(2) Then GoTo 101
    U(3) = Int(Abs(U(0)) / Num(0)) - 1
    If U(3) <= 0 Then GoTo 101
    xR(2, 1).Resize(U(3)).EntireRow.Insert
    xR.Resize(1, 3).Copy xR(2, 1).Resize(U(3), 3)
    For j = 1 To U(3)
        xR(j + 1, 4) = U(2) + Num(0) * j * IIf(U(0) >= 0, 1, -1)
    Next j
101: Next i
End Sub

[attach]31016[/attach]


=========================
作者: donod    時間: 2019-7-11 23:20

回復 13# 准提部林
感謝准提部林大大，可以了!因有很多檔案要處理，每次十萬行以上，有些還在運行中。沒有大大幫助，不可能完成。萬分感謝!
作者: 准提部林    時間: 2019-7-12 09:46

回復 14# donod


每次十萬行以上???
處理完區間後又變成幾行???

以這數據量, 上面那程式肯定太慢了~~
作者: 准提部林    時間: 2019-7-12 11:10

回復 14# donod


用這個跑看看:
[attach]31020[/attach]
作者: donod    時間: 2019-7-12 14:48

回復 16# 准提部林
謝謝准提部林再幫助，處理多過65536行就不行
作者: 准提部林    時間: 2019-7-12 15:10

回復 17# donod


換這個:
[attach]31021[/attach]
作者: donod    時間: 2019-7-12 17:48

本帖最後由 donod 於 2019-7-12 17:50 編輯

回復 18# 准提部林
感謝准提部林大大，執行部份很好，處理速度超快!只是還原不了。

[attach]31022[/attach]
作者: 准提部林    時間: 2019-7-12 18:04

回復 19# donod


還原--我這ok的

原始資料要先放在Sheet2
作者: donod    時間: 2019-7-12 18:52

回復 20# 准提部林
明白了，感謝准提部林大大循循善誘，用心指教!

再請教大大，以下這個問題，附件例子是實時將sheet1指定的資料，不斷記錄到sheet2，請教可否改為實時SAVE到D:\VBA\記錄.xlsx的Sheet1中，但D:\VBA\記錄.xlsx是不打開的，謝謝!
http://forum.twbts.com/thread-21903-1-2.html


[attach]31023[/attach]



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)