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

Question

Я хочу иметь макрос, который будет:

1. Определите на странице ("Оригинал") значение ячейки ($ E8, дата)
2. Перейдите на другую страницу ("Передача"), (имя страницы может отличаться, но имя соответствующей страницы отображается в "Оригинале" $ Z $ 1.)
3. Посмотрите вниз на столбец "Трансфер", в котором перечислены каждый понедельник (диапазон дат начинается с A20, текст выше).
4. Найдите понедельник перед датой $ E8 (поэтому для $ E8 = суббота 17-го будет понедельник 12-го)
5. Вставьте строку BENEATH в эту строку понедельника (перед строкой, в которой написано "Пн 19")
6. Стереть этот ряд (так что строка идет Mon-12, пусто, Mon-19
7. Вырезать / Копировать из («Оригинал $ E8») диапазона A8:H8
8. Перейти на страницу "Трансфер"
9. Вставьте этот выбор A8:H8 в строку, созданную в 5.
10. Вернитесь назад и делайте то же самое за $ E9, пока вся информация не будет помещена в "Transfer".

Ячейки, которые я дал, - это правильные ячейки, даты, которые я только что составил (они в любом случае различаются для каждой учетной записи).

Эрик очень любезно предоставил мне код, который я изменил, а именно:

 Public Sub do_stuff()
 Dim date_to_look_for As String
 Dim row As Integer

 date_to_look_for = Range("'Original'!K8").Value
                    '^L: This is the cell that you are reading from. Ensure it is the MONDAY formula
 row = 20
 '^L: This is where the Transfer date values start

 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
        '^L: Look for Original (X) Value specified above (make sure it's Monday).

    Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
          '^L: Once

    Range("'Transfer'!A" & row + 1 & ":H" & row + 1).Value = Range("'Original'!A8:H8").Value

         '^L:This is WHERE it will paste                           '^L: This is what will copy
    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 & ":H" & endrow).Value = 
 Range("'Original'!A8:H8").Value
 '^L: What is this?

 End Sub

(L: сообщения - это мои записи, когда я выяснил, что делал каждый раздел - пожалуйста, не стесняйтесь поправлять меня, если я неправильно понял. Другие зеленые заметки принадлежат Эрику, и я не уверен, что понимаю эти биты. Хотя мне это и не нужно, пока это работает, но если вы хотите научить меня программированию, не стесняйтесь: D)

Моя проблема сейчас в том, как сделать так, чтобы он зацикливался так, чтобы он работал вниз по исходным значениям (в данном случае столбец K, поэтому он переходит к K9, K10 и т.д., И делает то же самое? Кроме того, может ли он CUT вместо COPY, и удалить из оригинального листа после передачи?

Спасибо всем, кто помог, вы, ребята, великолепны!

Answer 1

Это должно делать то, что вы ищете. Я прокомментировал код, чтобы вы могли точно прочитать, что происходит. Обратите внимание, что этот код использует переменную типа 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

Answer 2

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

Данные в 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: