无法为Excel VBA编写macros以将特定的单元格值复制到下一个空白行

我有一个Excel电子表格，其值为29个空格。 我试图find一种方法将该值复制到下一个29空白行空间，然后再次循环，并将下一个值复制到以下29个空格。

每个值是不同的，没有顺序。 我有超过5万行，我花了很多时间试图find一种方法来做到这一点。 任何帮助深表感谢。 我相信我可以运行一个循环来完成这个任务，但是我是一个新手。 谢谢！

Answer 1

以下应该让你需要去的地方。 如果遇到任何问题，请再次提供详细信息：

Sub Copy29Rows() Dim wks As Excel.Worksheet Dim rng_Source As Excel.Range, rng_target As Excel.Range 'Change this to the name of the worksheet that you're working with Set wks = ThisWorkbook.Worksheets("Sheet2") 'Change the sheet and cell name to whatever your original source is. Set rng_Source = wks.Range("A1") 'Check that there is a value to copy If rng_Source.Value = "" Then MsgBox "There are no values to copy" GoTo ExitPoint End If 'We keep looping until we find no further values. Do While rng_Source.Value <> "" 'Make sure that you don't run off the end of the sheet If rng_Source.Row + 29 > wks.Rows.Count Then Err.Raise vbObjectError + 20000, , "There aren't enough empty rows in the sheet to copy down 29 rows." End If 'The target will be offset one row from the value that we're 'copying and will be 29 rows high. Set rng_target = rng_Source.Offset(1, 0).Resize(29, rng_Source.Columns.Count) 'Now copy the original value and paste it into the target range rng_Source.Copy rng_target 'Finally move the source 30 rows down. Set rng_Source = rng_Source.Offset(30, 0) Loop ExitPoint: On Error Resume Next Set rng_Source = Nothing Set rng_target = Nothing Set wks = Nothing On Error GoTo 0 Exit Sub ErrorHandler: MsgBox "Error " & Err.Number & vbCrLf & Err.Description Resume ExitPoint End Sub