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


1

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

  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 и т. Д., И делает то же самое? и удалить из оригинального листа после передачи?

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


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

И я разместил два существующих кода. Вы сказали, что ни один не будет работать без объяснения причин. Несмотря на то, что это иногда случается - я надеялся, что смогу это изменить. И когда я показал ошибку, которая вызвала сбой, вы не помогли. Если вы не можете или не хотите помочь, это нормально. Но, может быть, кто-то еще.
Лорен

Вы ответили здесь, но не там. Я мог только предположить, что вы либо не хотите, либо не можете помочь. Когда я пытаюсь запустить свой макрос соработников, он падает, когда он получает: «Если не найдено, то ничего не происходит». Excel зависает, и если я не получаю ESC, он падает. "@ScottCraner
Lauren

Лорен, не могли бы вы сделать скриншот рабочих листов "Оригинал" и "Перенос"? Вы можете аннулировать данные, я просто хотел бы увидеть структуру листа. Я могу помочь вам.
Нат

Я только что просмотрел ваш старый код и то, что вы опубликовали здесь. Просто некоторые общие замечания, которые могут помочь вам разобраться в вашей проблеме. Прежде всего, Range ("Sheet1"! A2 "). Value - это хороший способ ссылаться на значения ячеек вместо того, чтобы выбирать, а затем выполнять все другие операции, выполняемые устройством записи макросов. Когда вы «переходите» или «переводите», большинство из них можно выполнить в формате, аналогичном «Range» («Sheet2»! A2 »). Value = Range (« Sheet1 »! A2»). Value. Поскольку большая часть вашего поста посвящена копированию и вставке, использование этого метода должно прояснить большую часть того, что вы делаете ... просто замените имена листов, столбцы и строки
Eric F

Ответы:


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

Выглядит очень хорошо, спасибо, Нейт, но это не подходит. Я получаю сообщение об ошибке "не могу найти понедельник для 22/11/16". Значение Original-E8, 22/11/16, было вторником, так что оно должно было прорезаться между строк Transfer-A, говоря 21-го и 28-го. есть идеи?
Лорен

Это форматирование для значения dMonday. Гуглите функцию Format () и добавьте строку dMonday = Format (dMonday, «Ваш формат здесь») перед поиском. Попробуйте и дайте мне знать, я буду занят в ближайшее время.
Нат

Я изменил код выше, чтобы ошибка показывала вам, что именно она ищет. Это поможет вам понять, почему он не может найти соответствие. MsgBox ("Can't find the Monday for ") & rOriginal & ". Searching for Value " & dMonday
Нат

Там же я добавил строку для исправления форматирования. Я почти уверен, что это поможет.
Нат

Спасибо, Нейт, Эрик вроде бы работает нормально, у меня все еще есть кое-что исправить. Я исправлю ОП, если вы не против посмотреть? Большое спасибо BTW!
Лорен

0

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

введите описание изображения здесь

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

введите описание изображения здесь


Комментарии не для расширенного обсуждения; этот разговор был перенесен в чат .
DavidPostill
Используя наш сайт, вы подтверждаете, что прочитали и поняли нашу Политику в отношении файлов cookie и Политику конфиденциальности.
Licensed under cc by-sa 3.0 with attribution required.