Makro do wyszukiwania daty w zakresie kolumn, wstawiania wierszy i wklejania danych

Chcę mieć makro, które:

1. Wykryj na stronie („Oryginał”) wartość komórki (E8 $, data)
2. Przejdź do innej strony („Transfer”), (nazwa strony jest różna, ale odpowiednia nazwa strony pojawia się w „Oryginale” $ Z $ 1).
3. Spójrz w dół do kolumny „Transfer”, która zawiera listę w każdy poniedziałek (zakres dat zaczyna się od A20, tekst powyżej).
4. Znajdź poniedziałek przed datą E8 $ (więc dla E8 = 17 sobota, znalazłby się pon. 12)
5. Wstaw wiersz BENEATH w ten poniedziałkowy wiersz (czyli przed wierszem z poniedziałkiem 19)
6. Skasuj ten wiersz (więc wiersz przechodzi od Pon-12, puste, Pon-19
7. Wytnij / Kopiuj z („Original $ E8”) z zakresu A8: H8
8. Przejdź do strony „Transfer”
9. Wstaw zaznaczenie A8: H8 do wiersza utworzonego na 5.
10. Zapętlić i zrobić to samo za E9 $, dopóki wszystkie informacje nie zostaną umieszczone w „Transfer”.

Komórki, które podałem, to właściwe komórki, daty, które właśnie wymyśliłem (i tak różnią się dla każdego konta).

Eric bardzo uprzejmie podał mi zmodyfikowany przeze mnie kod:

 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

(Wiadomości L: są moimi notatkami, gdy opracowałem, co zrobiły poszczególne sekcje - prosimy o poprawienie mnie, jeśli źle zrozumiałem. Inne zielone „notatki są Erica i nie jestem pewien, czy rozumiem te fragmenty. Nie rozumiem Naprawdę muszę to robić, o ile działa, ale jeśli chcesz nauczyć mnie kodowania, nie krępuj się: D)

Mój problem polega teraz na tym, jak zrobić pętlę, aby działała w dół do oryginalnych wartości (w tym przypadku kolumna K, więc idzie do K9, K10 itp. I robi to samo? Czy to może CIĘĆ zamiast KOPIOWAĆ i usunąć z oryginalnego arkusza po przeniesieniu?

Dzięki wszystkim, którzy pomagali, jesteście świetni!

To powinno zrobić to, czego szukasz. Skomentowałem kod, abyś mógł dokładnie przeczytać, co się dzieje. Zauważ, że ten kod używa zmiennej typu Range, co oznacza, że ​​zmienne rTransfer i rOriginal odnoszą się do rzeczywistych komórek w arkuszu.

Mam nadzieję że to pomoże! Powodzenia!

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

Oto przykład, który moim zdaniem oddaje to, co próbujesz zrobić w sensie ogólnym. Skonfigurowałem dwie zakładki w moim skoroszycie oznaczone jako Przeniesienie i Oryginał, tak jak Ty. Skonfigurowałem kartę Original, aby wyglądała następująco:

Dane w A, B, C, D tak naprawdę nie mają znaczenia. Mam kolumnę F i G, aby ustalić, która data jest „ostatnim poniedziałkiem”. Można to oczywiście zrobić w jednej komórce, ale podzieliłem ją na części, aby lepiej zrozumieć. W tym przykładzie moja komórka F2 ma wartość = WEEKDAY (A2) -2, ponieważ funkcja WEEKDAY zwraca dzień tygodnia jako liczbę. Mam G2 ustawione na = A2-F2, aby faktycznie pokazywać „datę ostatniego poniedziałku”.

Mój arkusz przelewu wygląda następująco:

Od tego momentu musimy sprawdzić makro, który wiersz jest ostatnią datą poniedziałku na karcie Transfer. Musimy także upewnić się, że istnieje. W moim przykładzie, jeśli nie istnieje, po prostu przykleję go do dołu ...

Oto, co napisałem dla mojego przykładu z wieloma komentarzami:

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

Zauważ, jak mogę skopiować dane za jednym razem za pomocą funkcji wartości Range (). Zwróć też uwagę, jak mogę również określić zakres.

Po uruchomieniu pokazanego powyżej makra powinieneś zobaczyć to na karcie Transfer: