[已解决]跳过栏位，后面所有空白数值往前补上

lkk0063

1.檔案 "In"傳送資料至"Out", 跳过栏位，后面所有空白数值往前补上
2. 若要实现多个栏位，是否直接修改 i 的数量
If i = 5 Or i = 8 Or i = 9 Then GoTo 10

1. <div class="cl" style="zoom: 1; color: rgb(0, 0, 0); margin-top: 15px;">Private Sub CommandButton2_Click()
   
2.     Dim Arr, Brr, i&, j%, xE As Range
   
3.     Arr = [A3:J17]
   
4.     ReDim Brr(1 To 2, 1 To [A:bx].Columns.Count)
   
5.     Brr(1, 1) = Split([G1], "-")(0) & "-FQC"
   
6.     Brr(1, 2) = Year([C1])
   
7.     Brr(1, 3) = [C1]
   
8.     Brr(1, 4) = [E1]
   
9. 
   
10.     For i = 0 To UBound(Arr) - 1
    
11.         If i = 5 Or i = 9 Then GoTo 10
    
12.         If i >= UBound(Arr) - 1 Then
    
13.             For j = 5 To 6: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j
    
14.         Else
    
15.             For j = 5 To 9: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j
    
16. 
    
17.         End If
    
18. 10    Next i
    
19. 
    
20.     Dim xN$, xB As Workbook, xS As Worksheet, xF As Range
    
21.     xN = "Out.xlsm"
    
22.     On Error Resume Next
    
23.     Set xB = Workbooks(xN)
    
24.     If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "" & xN)
    
25.     On Error GoTo 0
    
26.     If xB Is Nothing Then MsgBox "can't find〔" & xN & "〕file": Exit Sub
    
27. 
    
28.     Set xS = xB.Sheets("BB")
    
29.     Set xF = xS.[A:A].Find(Split(Brr(1, 1), "-")(0), Lookat:=xlPart)
    
30.     If Not xF Is Nothing Then MsgBox "Two lots": xB.Close 0: Exit Sub
    
31.     Set xE = xS.[A65536].End(xlUp)(2)
    
32.     If xE.Row < 6 Then Set xE = xE(2)
    
33.     xE.Resize(2, UBound(Brr, 2)) = Brr
    
34.     xB.Close 1
    
35. End Sub</div>

复制代码

最佳答案

月排行榜 / 总排行榜

zjdh

2022-9-14 18:03

若要实现多个栏位，则直接修改 i 的数量
If i = 5 Or i = 8 Or i = 9  Or.......Then GoTo 10

若采用在k列做标记的话，就比较简单了。
假设跳过的行，在k列输入“F“，则

Private Sub CommandButton2_Click()
Dim Arr, Brr, i&, j%, xE As Range
Arr = [A3:K17]
ReDim Brr(1 To 2, 1 To [A:bx].Columns.Count)
Brr(1, 1) = Split([G1], "-")(0) & "-FQC"
Brr(1, 2) = Year([C1])
Brr(1, 3) = [C1]
Brr(1, 4) = [E1]
k = 0
For i = 0 To UBound(Arr) - 1

   If Arr(i+1, 11) = "F" Then GoTo 10
   
    If i >= UBound(Arr) - 1 Then
       For j = 5 To 6: Brr(1, k * 5 + j) = Arr(i + 1, j + 1): Next j
    Else
       For j = 5 To 9: Brr(1, k * 5 + j) = Arr(i + 1, j + 1): Next j
    End If
    k = k + 1
10     Next i
.................
End Sub

跳转到最佳答案楼层

zjdh

重新设置一个变量，有效数据按顺序复制到数组Brr。
Private Sub CommandButton2_Click()
    Dim Arr, Brr, i&, j%, xE As Range, K&
    Arr = [A3:J17]
    ReDim Brr(1 To 2, 1 To [A:bx].Columns.Count)
    Brr(1, 1) = Split([G1], "-")(0) & "-FQC"
    Brr(1, 2) = Year([C1])
    Brr(1, 3) = [C1]
    Brr(1, 4) = [E1]
    K = 0
    For i = 0 To UBound(Arr) - 1
        If i = 5 Or i = 9 Then GoTo 10
        If i >= UBound(Arr) - 1 Then
            For j = 5 To 6: Brr(1, K * 5 + j) = Arr(i + 1, j + 1): Next j
        Else
            For j = 5 To 9: Brr(1, K * 5 + j) = Arr(i + 1, j + 1): Next j

        End If
        K = K + 1
10    Next i

    Dim xN$, xB As Workbook, xS As Worksheet, xF As Range
    xN = "Out.xlsm"
    On Error Resume Next
    Set xB = Workbooks(xN)
    If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "\" & xN)
    On Error GoTo 0
    If xB Is Nothing Then MsgBox "can't find〔" & xN & "〕file": Exit Sub

    Set xS = xB.Sheets("BB")
    Set xF = xS.[A:A].Find(Split(Brr(1, 1), "-")(0), Lookat:=xlPart)
    If Not xF Is Nothing Then MsgBox "Two lots": xB.Close 0: Exit Sub
    Set xE = xS.[A65536].End(xlUp)(2)
    If xE.Row < 6 Then Set xE = xE(2)
    xE.Resize(2, UBound(Brr, 2)) = Brr
    xB.Close 1
End Sub

zjdh

若要实现多个栏位，则直接修改 i 的数量
If i = 5 Or i = 8 Or i = 9  Or.......Then GoTo 10

若采用在k列做标记的话，就比较简单了。
假设跳过的行，在k列输入“F“，则

Private Sub CommandButton2_Click()
Dim Arr, Brr, i&, j%, xE As Range
Arr = [A3:K17]
ReDim Brr(1 To 2, 1 To [A:bx].Columns.Count)
Brr(1, 1) = Split([G1], "-")(0) & "-FQC"
Brr(1, 2) = Year([C1])
Brr(1, 3) = [C1]
Brr(1, 4) = [E1]
k = 0
For i = 0 To UBound(Arr) - 1

   If Arr(i+1, 11) = "F" Then GoTo 10
   
    If i >= UBound(Arr) - 1 Then
       For j = 5 To 6: Brr(1, k * 5 + j) = Arr(i + 1, j + 1): Next j
    Else
       For j = 5 To 9: Brr(1, k * 5 + j) = Arr(i + 1, j + 1): Next j
    End If
    k = k + 1
10     Next i
.................
End Sub