Макрос для поиска даты в диапазоне столбцов, вставки строки и вставки данных

Это должно делать то, что вы ищете. Я прокомментировал код, чтобы вы могли точно прочитать, что происходит. Обратите внимание, что этот код использует переменную типа Range, что означает, что переменные rTransfer и rOriginal ссылаются на фактические ячейки на листе.

Надеюсь это поможет! Удачи!

Sub TransferMyData() 'Declare the variables to be used in the code Dim wsTransfer As Worksheet, wsOriginal As Worksheet Dim rTransfer As Range, rOriginal As Range, rCopyRange As Range Dim dMonday As Variant Dim iRow As Integer  'Set the worksheet variable, this makes is easier than constantly referencing each sheet in the code all the time Set wsTransfer = ThisWorkbook.Worksheets("Transfer") Set wsOriginal = ThisWorkbook.Worksheets("Original")  'Set rOriginal to reference range E8, the first cell we are checking for a date to transfer Set rOriginal = wsOriginal.Range("E8")  'Run this loop over and over until the cell referenced in rOriginal is blank. 'At the bottom of the loop we shift rOriginal down by one Do While rOriginal <> "" 'Find the Monday of the week for rOriginal dMonday = rOriginal - Weekday(rOriginal, 3)  'Format dMonay to match the Transfer worksheet - Commented out 'dMonday = Format(dMonday, "dd-mm-yy")  'Set the cell of rTransfer using the Find function (Search range A:A in wsTransfer for the monday we figured out above) Set rTransfer = wsTransfer.Range("A:A").Find(dMonday)  'Error check. If rTransfer returns nothing then no match was found If rTransfer Is Nothing Then MsgBox ("Can't find the Monday for ") & rOriginal & ". Searching for Value " & dMonday Exit Sub End If  'Check if there was already some data transfered in for that week (rTransfer.Offset(1,4) references the 'E' column of the row below). 'If there is a value there, shift down by one and check again Do Until rTransfer.Offset(1, 4) = "" Set rTransfer = rTransfer.Offset(1, 0) Loop  'Insert a blank row below rTransfer using the offset function rTransfer.Offset(1, 0).EntireRow.Insert  'Set iRow to be the row number of rOriginal to be used below iRow = rOriginal.Row  'Set the range rCopyRange to be the range A:H of the row for iRow (See https://www.mrexcel.com/forum/excel-questions/48711-range-r1c1-format-visual-basic-applications.html for explanation) Set rCopyRange = wsOriginal.Range(Cells(iRow, 1).Address, Cells(iRow, 8).Address)  'Copy the range rCopyRange into the blank row we added rCopyRange.Copy rTransfer.Offset(1, 0)  'Offset our rOriginal cell down by one and restart the loop Set rOriginal = rOriginal.Offset(1, 0)  'Clear out the copied range. Can replace with rCopyRange.Delete if you want to delete the cells and have everything shift up rCopyRange.Clear  'Simple error check, if for some reasone you're stuck in an endless loop this will break out If rOriginal.Row > 999 Then MsgBox "Error! Stuck in Loop!" Exit Sub End If Loop  End Sub 

Итак, вот пример, который, я считаю, отражает то, что вы пытаетесь сделать в общем смысле. Я настроил две вкладки в своей книге с надписью Перенос и Оригинал, как и вы. Я настроил свою вкладку «Оригинал», чтобы она выглядела следующим образом:

Данные в A, B, C, D на самом деле не имеют значения. У меня есть столбцы F и G, чтобы определить, какой датой является «последний понедельник». Это, конечно, можно сделать в одной камере, но я разбил ее на части, чтобы вы могли лучше понять. Таким образом, в этом примере моя ячейка F2 имеет = WEEKDAY (A2) -2, поскольку функция WEEKDAY возвращает день недели в виде числа. Я установил G2 как = A2-F2, чтобы фактически показать «дату последнего понедельника».

Мой лист перевода выглядит следующим образом:

Таким образом, отсюда нам нужно, чтобы макрос посмотрел, какая строка является последней датой понедельника на вкладке «Передача». Мы также должны убедиться, что он существует. В моем примере, если он не существует, я просто добавлю его к основанию ...

Вот что я написал для моего примера с большим количеством комментариев:

Public Sub do_stuff() Dim date_to_look_for As String Dim row As Integer  date_to_look_for = Range("'Original'!G2").Value row = 2 'whichever row is your start row for the data on the Transfer tab  Do Until row = Range("'Transfer'!A1").End(xlDown).row + 1 'create our loop. 'Notice that the .end function will find the end of the data in a column  If Range("'Transfer'!A" & row).Value = date_to_look_for Then 'row found for Monday! Do our magic here!  'insert a blank spot at the row found + 1 Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'now copy data here Range("'Transfer'!A" & row + 1 & ":E" & row + 1).Value = Range("'Original'!A2:E2").Value Exit Sub 'no sense in running loop more if already found End If row = row + 1 Loop  'If code gets here then the date was never found! so tack to end of list Dim endrow As Integer endrow = Range("'Transfer'!A1").End(xlDown).row  Range("'Transfer'!A" & endrow & ":E" & endrow).Value =  Range("'Original'!A2:E2").Value  End Sub 

Обратите внимание, как я могу скопировать данные за один раз, используя функцию Range (). Value, а также обратите внимание, как я также могу указать диапазон.

После запуска макроса, показанного выше, вы должны увидеть это на вкладке Transfer: