[已解决]Sheet 复制问题

lkk0063

依照现行的程式码修改执行动作如下 : 按下 add data to out 按钮, 若想要将表（In）资料复制到表（Out）但是需要跳过F8：J8与F12：J12请问如何修改程式？

1. 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 >= UBound(Arr) - 1 Then
    
12.        For j = 5 To 6: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j
    
13.     Else
    
14.        For j = 5 To 9: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j
    
15.       
    
16.     End If
    
17.      Next i
    
18. 
    
19. Dim xN$, xB As Workbook, xS As Worksheet, xF As Range
    
20. xN = "Out.xlsm"
    
21. On Error Resume Next
    
22. Set xB = Workbooks(xN)
    
23. If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "" & xN)
    
24. On Error GoTo 0
    
25. If xB Is Nothing Then MsgBox "can't find〔" & xN & "〕file": Exit Sub
    
26. 
    
27. Set xS = xB.Sheets("BB")
    
28. Set xF = xS.[A:A].Find(Split(Brr(1, 1), "-")(0), Lookat:=xlPart)
    
29. If Not xF Is Nothing Then MsgBox "Two lots": xB.Close 0: Exit Sub
    
30. Set xE = xS.[A65536].End(xlUp)(2)
    
31. If xE.Row < 6 Then Set xE = xE(2)
    
32. xE.Resize(2, UBound(Brr, 2)) = Brr
    
33. xB.Close 1
    
34. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

zjdh

2022-9-7 17:28

Private Sub CommandButton2_Click()
    Dim Arr, Brr, i&, j%, xE As Range
    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]

    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, i * 5 + j) = Arr(i + 1, j + 1): Next j
        Else
            For j = 5 To 9: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j

        End If
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

Private Sub CommandButton2_Click()
    Dim Arr, Brr, i&, j%, xE As Range
    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]

    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, i * 5 + j) = Arr(i + 1, j + 1): Next j
        Else
            For j = 5 To 9: Brr(1, i * 5 + j) = Arr(i + 1, j + 1): Next j

        End If
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

lkk0063

zjdh 发表于 2022-9-7 17:28
Private Sub CommandButton2_Click()
    Dim Arr, Brr, i&, j%, xE As Range
    Arr = [A3:J17]

又有一个问题，虽然是跳过栏位，但我想把后面数值往前递补，该怎么做？

zjdh

那样在Out文件中不是错位了吗？

lkk0063

zjdh 发表于 2022-9-13 15:56
那样在Out文件中不是错位了吗？

没关系, 我是要把跳过资料不显示

zjdh

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

lkk0063

zjdh 发表于 2022-9-13 16:37
Private Sub CommandButton2_Click()
    Dim Arr, Brr, i&, j%, xE As Range, K&
    Arr = [A3:J17]

版主你好
有点不明白为何加上K=0, K+1 就可以将数值补上?

1. K = 0
   
2.     For i = 0 To UBound(Arr) - 1
   
3.         If i = 5 Or i = 9 Then GoTo 10
   
4.         If i >= UBound(Arr) - 1 Then
   
5.             For j = 5 To 6: Brr(1, K * 5 + j) = Arr(i + 1, j + 1): Next j
   
6.         Else
   
7.             For j = 5 To 9: Brr(1, K * 5 + j) = Arr(i + 1, j + 1): Next j
   
8. 
   
9.         End If
   
10.         K = K + 1

复制代码

zjdh

仔细分析我涂红的几句语句！