Блог

Предположим, у вас есть данные Excel в формате

 Row A Row B Row C  blank row Row X Row Y Row Z blank  

Я хотел бы 1) перейти к строке с пробелом 2) скопировать все содержимое двух строк выше 3) вставить содержимое.

В приведенном выше примере результаты будут следующими

 Row A Row B Row C Row B Row C blank Row X Row Y Row Z Row Y Row Z blank  

Я в состоянии найти пробелы. Мой код в настоящее время выглядит примерно так

 Sub Find_Copy()  Dim rCell As Range Dim r As Range Dim r2 As Range  'We call the function and tell it to start the search in cell B1. Set rCell = FindNextEmpty(Range("B8")) 'this is a separate function  'Shows a message box with the cell address. Right here is where 'you write the code that uses the empty cell. rCell.Value = "Filled by macro 999" MsgBox rCell.Address amp; " " amp; rCell.Value   rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks  Selection.Copy  Selection.Insert Shift:=xlDown   Set rCell = Nothing  End Sub  

Кто-нибудь может помочь мне разобраться с этим? Спасибо!

Субмарина, которая выполняет эту работу, такова enhanceList . В качестве параметра он принимает диапазон, с которым вы хотите работать.

Основная идея моего макроса состоит в том, чтобы работать снизу вверх при вставке строк.

 Option Explicit  Public Sub test_enhanceList() Dim rg As Range Set rg = table1.Range("A1:A8") 'lt;lt;lt; adjust to your needs  enhanceList rg  End Sub    ' The sub which does the work Private Sub enhanceList(rgToEnhance As Range)  Dim c As Range With rgToEnhance  'we will start at the end of the range  Set c = .Cells(.Rows.Count) End With  Dim i As Long  Do  If LenB(c.Value2) = 0 Then 'test for empty cell  For i = 1 To 2  'insert empty row and take value from 3rd row above  c.EntireRow.Insert xlShiftDown  'c.offset(-1) = new cell  'c.offset(-3) = value to copy  c.Offset(-3).EntireRow.Copy c.Offset(-1)  Next  End If  Set c = c.Offset(-1) 'set c to the cell above Loop Until c.Row = rgToEnhance.Cells(1, 1).Row 'stop when first cell is reached  End Sub  

Добавьте это после вставки, и вы сможете получить правильные строки B и C. Вам придется добавить цикл с ограничением диапазона, начинающимся до вызова функции, чтобы получить следующую пустую ячейку для добавления Y и Z и всего остального, что может последовать. Опубликуйте свой код функции, и я, вероятно, смогу написать цикл, который сделает это позже.

 rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks Selection.Copy  rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks Selection.Insert Shift:=xlDown  

Чтобы выбрать столбец, в котором вы хотите это сделать, нажав на него, измените эту строку:

 Set rCell = FindNextEmpty(ActiveCell.Offset(0, 0))  

К этому:

 Set rCell = FindNextEmpty(Selection)  

Затем перед запуском макроса выберите ячейку B1

Вместо того чтобы изменить свой ответ, я добавил новый. Добавила пару строк, чтобы найти диапазон данных, а затем прошлась по каждой ячейке в диапазоне, проверяя, пусто ли. Это устраняет необходимость в дополнительной функции.

Попробуй это:

 Sub Dan_Find_Copy()  Dim wkb As Workbook Dim rCell As Range Dim r As Range Dim r2 As Range Dim colNumber As Integer 'to store the column index Dim rowNumber As Long 'to store the last row containing data Dim i As Long 'iterator   'Need to get the range of the data Set wkb = ActiveWorkbook 'store the column number of the selection colNumber = Columns(Selection.Column).Column 'find the last row containing data rowNumber = Cells(Rows.Count, colNumber).End(xlUp).Row Set r = wkb.ActiveSheet.Range(Sheet1.Cells(1, colNumber), Sheet1.Cells(rowNumber, colNumber))  For Each rCell In r.Cells  If rCell.Value = "" Then  If MsgBox("Continue?", vbOKCancel, "Hello!") = vbOK Then   'Shows a message box with the cell address. Right here is where  'you write the code that uses the empty cell.  rCell.Value = "Filled by macro 999"  MsgBox rCell.Address amp; " " amp; rCell.Value    rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks  Selection.Copy  Selection.Insert Shift:=xlDown    rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks  Selection.Copy    rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks  Selection.Insert Shift:=xlDown    rCell.Select    Else   MsgBox ("You cancelled the process.")  Exit For    End If    End If   Next rCell    Set rCell = Nothing Set r = Nothing Set wkb = Nothing  End Sub