新人求助：长江后浪推前浪前浪拍死沙滩上

jsh123

想做一个按钮，只要点击一下就能实现下面的步骤；

1、首先判断（H列)某行是否为空，如果非空，
2、把非空行(B：F)列里面的数据剪切、粘贴到沙滩表（B：F)列中，行与行间不要有空行。
3、再把非空行(D：F)列内容替换为同一行(H：J)列的内容，同时(H：J)列清空。

jsh123

zxsea_7426 发表于 2023-4-12 22:27
未例保留原工作表，数据全部以备份表名加1做为数据源以及输出表

老师好！粘贴到沙滩表中的数据要一直保留，有新数据时前面已有数据保留，把新数据粘贴在下面，这段代码在每运行一次就把沙滩表中的数据全部删除后在粘贴新数据的。

jsh123

zxsea_7426 发表于 2023-4-13 10:20
修改两行代码就好，去除删除，并输出到最后一行就可以了。

老师好！如果想把数据粘贴到沙滩中A:F列更换到D:I列，怎么办？
还有就是代码运行完后，长江表中G列中函数公式也被删除了，能跳过G列保留公式吗？

zxsea_7426

未例保留原工作表，数据全部以备份表名加1做为数据源以及输出表

1. Sub test()
   
2.     With Sheets("长江1")
   
3.         R = .Cells(Rows.Count, "H").End(3).Row
   
4.         ar = .Range(.[a1], .Cells(R, "j"))
   
5.         ReDim arr(1 To UBound(ar), 1 To 6)
   
6.         For i = 3 To UBound(ar)
   
7.             If ar(i, 8) <> "" Then
   
8.                 n = n + 1
   
9.                 arr(n, 1) = n
   
10.                 For j = 2 To 6
    
11.                     arr(n, j) = ar(i, j)
    
12.                 Next j
    
13.                 For j = 4 To 6
    
14.                     ar(i, j) = ar(i, j + 4): ar(i, j + 4) = ""
    
15.                 Next j
    
16.             End If
    
17.         Next i
    
18.         .[a1].Resize(UBound(ar), UBound(ar, 2)) = ar
    
19.     End With
    
20.     With Sheets("沙滩1")
    
21.         .Cells.ClearContents
    
22.         Sheets("长江1").[a2].Resize(1, 6).Copy .[a1]
    
23.         .[a2].Resize(n, 6) = arr
    
24.     End With
    
25. End Sub

复制代码

zxsea_7426

楼上未使用复制粘贴，使用了数据传递

mmwwdd

Private Sub CommandButton1_Click()
    Dim lastRow As Long
    lastRow = Range("H" & Rows.Count).End(xlUp).Row
   
    If Not IsEmpty(Range("H" & lastRow)) Then
        Range("B" & lastRow & ":F" & lastRow).Cut
        Sheets("沙滩表").Select
        lastRow = Sheets("沙滩表").Range("B" & Rows.Count).End(xlUp).Row
        Range("B" & lastRow + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        
        Range("D" & lastRow & ":F" & lastRow).Value = Range("H" & lastRow & ":J" & lastRow).Value
        Range("H" & lastRow & ":J" & lastRow).ClearContents
    End If
End Sub

mmwwdd

jsh123

mmwwdd 发表于 2023-4-13 07:50
Private Sub CommandButton1_Click()
    Dim lastRow As Long
    lastRow = Range("H" & Rows.Count).E ...

老师好！运行提示错误下标越界后，我把”沙滩表“改为“沙滩：后
运行提示错误1004：rang的select方法无效

zxsea_7426

jsh123 发表于 2023-4-13 10:04
老师好！粘贴到沙滩表中的数据要一直保留，这段代码在每运行一次就把沙滩表中的数据全部删除后在粘贴的

修改两行代码就好，去除删除，并输出到最后一行就可以了。

1. Sub test()
   
2.     With Sheets("长江1")
   
3.         R = .Cells(Rows.Count, "H").End(3).Row
   
4.         ar = .Range(.[a1], .Cells(R, "j"))
   
5.         ReDim arr(1 To UBound(ar), 1 To 6)
   
6.         For i = 3 To UBound(ar)
   
7.             If ar(i, 8) <> "" Then
   
8.                 n = n + 1
   
9.                 arr(n, 1) = n
   
10.                 For j = 2 To 6
    
11.                     arr(n, j) = ar(i, j)
    
12.                 Next j
    
13.                 For j = 4 To 6
    
14.                     ar(i, j) = ar(i, j + 4): ar(i, j + 4) = ""
    
15.                 Next j
    
16.             End If
    
17.         Next i
    
18.         .[a1].Resize(UBound(ar), UBound(ar, 2)) = ar
    
19.     End With
    
20.     With Sheets("沙滩1")
    
21.         '        .Cells.ClearContents
    
22.         '        Sheets("长江1").[a2].Resize(1, 6).Copy .[a1]
    
23.         '        .[a2].Resize(n, 6) = arr
    
24.         lst_row = .Cells(Rows.Count, 1).End(3).Row  '最后一行行号
    
25.         If lst_row > 1 Then             '最后一行大于1行说明该表已有数据，直接在最后一行下一行输出
    
26.             .Cells(lst_row + 1, 1).End(3).Offset(1, 0).Resize(n, 6) = arr
    
27.         Else                            '最后一行低于2行说明该表没有数据,重新复制表头并输出数据
    
28.             Sheets("长江1").[a2].Resize(1, 6).Copy .[a1]
    
29.             .[a2].Resize(n, 6) = arr
    
30.         End If
    
31.     End With
    
32.     Erase ar
    
33.     Erase arr
    
34. End Sub

复制代码

洋务德雷

~~~~~~~~~~~SQL+VBA

jsh123

洋务德雷 发表于 2023-4-13 10:49
~~~~~~~~~~~SQL+VBA

谢谢老师！