Excel - Criando macro para pesquisar e copiar

Questão

Eu tenho uma planilha com todas as datas diferentes com os dados correspondentes em sua linha. Existem muitas linhas com a mesma data e quero criar uma macro para pesquisar todas as mesmas datas e copiá-las e colá-las na folha 2 para que eu possa colocá-las em ordem

exemplo:

 27-set 27-set 27-set 28-set 28-set 01-out 01-out

Eu não tenho idéia de como criar uma macro, no entanto eu procurei por toda a internet para encontrar um que eu poderia modificar para inserir meus próprios dados, e é isso que eu sugiro.

 Sub SearchForString () Dim LSearchRow Como Integer Dim LCopyToRow Como Integer On Erro Ir Para Err_Execute 'Iniciar pesquisa na linha 6 LSearchRow = 6' Iniciar cópia de dados na linha 110 na Folha2 (variável de contador de linha) LCopyToRow = 110 While Len (Range ("A" & CStr (LSearchRow)). Value)> 0 'Se o valor na coluna A = "27-Sep", copie toda a linha para Sheet2 Se Range ("A" & CStr (LSearchRow)). Value = "27 = Sep" Então "Selecione a linha na Folha1 para copiar Linhas (CStr (LSearchRow) &": "& CStr (LSearchRow)). Selecione Selection.Copy 'Colar linha na Folha2 na próxima linha Folhas (" Folha2 "). Selecionar linhas (CStr (LCopyToRow) & ":" & CStr (LCopyToRow).) Selecione ActiveSheet.Paste 'Mover contador para a próxima linha LCopyToRow = LCopyToRow + 1' Voltar para Sheet1 para continuar pesquisando Sheets ("Sheet1"). Selecione End If LSearchRow = LSearchRow + 1 Wend 'Posição na célula A109 Application.CutCopyMode = False Range ("A109"). Selecione MsgBox "Todos os dados correspondentes foram copiados." Saia Sub Err_Execute: MsgBox "Ocorreu um erro". End Sub

Solução

Eu estou dando duas macros "teste" e "desfazer"

a folha de amostra é assim (folha1) - não é necessário classificar

data data1 data2

01/03/2010 37 1

3/2/2010 65 96

3/3/2010 48 46

02/03/2010 78 54

3/5/2010 3 38

3/2/2010 83 58

3/3/2010 45 78

tente a macro "teste" e veja a folha 2

se você quiser retestar

1.run "desfazer"

então

2.rung "teste"

as macros são

 Subteste () Dim r Como Faixa, r1 Como Faixa, r2 Como Faixa Dim c2 Como Faixa, cfind Como Faixa de Trabalho Folhas ("folha1"). Ativar Definido r = Intervalo (Faixa ("A1"), Faixa ("A1") .End (xlDown)) Defina r1 = Range ("a1"). End (xlDown) .Offset (5, 0) Ação r.AdvancedFilter: = xlFilterCopy, copytorange: = r1, exclusivo: = True Set r2 = Range (r1 Deslocamento (1, 0), r1.End (xlDown)) Para cada c2 em r2 Se WorksheetFunction.CountIf (r, c2)> 1 Então, com intervalo ("A1"). CurrentRegion .AutoFilter campo: = 1, Critério1: = c2.Value .Cells.SpecialCells (xlCellTypeVisible) .Copy Worksheets ("sheet2"). Células (Rows.Count, "A"). End (xlUp) .Offset (1, 0) .PasteSpecial End With End Se ActiveSheet. AutoFilterMode = False Next c2 Worksheets ("sheet2"). Ativar Do Set cfind = ActiveSheet.Cells.Find (o que: = "data", lookat: = xlWhole, depois: = Range ("A2")) Se cfind não for nada então Exit Do cfind.EntireRow.Delete Planilhas Loop ("sheet1"). Range ("A1"). Planilhas EntireRow.Copy ("sheet2"). Range ("A1"). PasteSpecial Application.CutCopyMode = False End Sub Sub desfazer ( ) Worksheets ("sheet2"). Células. Limpar Sub End