Macro para procurar data no intervalo da coluna, inserir linha e colar dados

Question

O que eu quero fazer é ter uma macro que:

1. Detecta, na página ("Original"), o valor de uma célula ($ E8, uma data)
2. Vá para outra página ("Transferir"), (o nome da página varia, mas o nome da página apropriada aparece em "Original" $ Z $ 1.)
3. Olhe para baixo na coluna A de "Transferir", que lista toda segunda-feira (o intervalo de datas começa em A20, texto acima).
4. Encontre a segunda-feira anterior àquela data de $ E8 (assim, para $ E8 = Sáb 17, encontrará Mon 12)
5. Inserir uma linha BENEATH daquela linha de segunda-feira (antes da linha que diz seg 19)
6. Apague essa linha (assim a linha vai seg-12, em branco, seg-19
7. Recortar / Copiar de ("Original $ E8") o intervalo A8: H8
8. Ir para a página "Transferir"
9. Insira essa seleção A8: H8 na linha criada em 5.
10. Volte e faça o mesmo por $ E9 até que todas as informações tenham sido colocadas em "Transferir".

As células que eu forneci são as células certas, as datas que acabei de inventar (elas variam para cada conta de qualquer maneira).

Eric gentilmente me forneceu um código que eu modifiquei, que é o seguinte:

 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

(As mensagens L: são minhas anotações enquanto eu resolvia o que cada seção fazia - sinta-se à vontade para me corrigir se eu tiver entendido errado. As outras notas verdes são do Eric e não tenho certeza se entendi essas partes. Eu realmente não preciso, desde que funcione, mas se você quiser me ensinar sobre codificação, por favor, sinta-se à vontade: D)

Meu problema agora é como fazê-lo funcionar de modo que ele desça os valores originais (neste caso, a coluna K, então ele vai para K9, K10, etc, e faz a mesma coisa? Além disso, pode ser CUT em vez de COPY, e remova da folha original depois de transferida?

Obrigado a todos que ajudaram, vocês são ótimos!

    

Answer 1

Isso deve fazer o que você está procurando. Eu comentei o código para que você possa ler exatamente o que está acontecendo. Observe que esse código usa a variável Range, o que significa que as variáveis rTransfer e rOriginal estão fazendo referência a células reais na planilha.

Espero que isso ajude! Boa sorte!

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

Então, aqui está um exemplo que acredito capta o que você está tentando fazer em um sentido geral. Eu configurei duas guias em minha pasta de trabalho rotulada Transfer e Original como você. Eu configurei minha guia original para ter a seguinte aparência:

OsdadosemA,B,C,Dnãoimportamrealmente.EutenhocolunasFeGparadeterminarqualdataéa"segunda-feira passada". Isso, claro, pode ser feito em uma célula, mas eu a separei para que você possa entender melhor. Portanto, neste exemplo, minha célula F2 tem = WEEKDAY (A2) -2 como a função WEEKDAY retorna o dia da semana como um número. Eu tenho G2 definido como = A2-F2 para realmente mostrar a "data da última segunda-feira".

Eu tenho minha folha de transferência com esta aparência:

Portanto,apartirdaqui,precisamosqueamacroprocurequallinhaéaúltimasegunda-feiradaguia"Transferir". Também devemos nos certificar de que existe. No meu exemplo, se ele não existir, vou apenas colá-lo no final ...

Aqui está o que escrevi para o meu exemplo com muitos comentários:

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

Observe como eu posso copiar dados de uma só vez usando a função de valor Range (). e também percebo como eu posso especificar um intervalo também.

Depois de executar a macro mostrada acima, você verá isso na guia "Transferência":