Excel - Создание макроса для поиска и копирования

вопрос

У меня есть таблица со всеми разными датами с соответствующими данными в ее строке. Есть много строк с одинаковой датой, и я хочу создать макрос для поиска всех одинаковых дат, скопировать и вставить их на лист 2, чтобы я мог расположить их в порядке

пример:

 27 сентября 27 сентября 27 сентября 28 сентября 28 сентября 01 октября 01 октября

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

 Sub SearchForString () Dim LSearchRow As Integer Dim LCopyToRow As Integer On Error GoTo Err_Execute 'Начать поиск в строке 6 LSearchRow = 6' Начать копирование данных в строку 110 в Sheet2 (переменная счетчика строк) LCopyToRow = 110 While Len (Range ("A") & CStr (LSearchRow)). Value)> 0 'Если значение в столбце A = «27 сентября», скопировать всю строку в Sheet2 If Range («A» & CStr (LSearchRow)). Value = «27 = Sep» Тогда 'Выберите строку в Sheet1, чтобы скопировать строки (CStr (LSearchRow) & ":" & CStr (LSearchRow)). Select Selection.Copy' Вставить строку в Sheet2 в следующей строке Sheets ("Sheet2"). Выбрать строки (CStr (LCopyToRow) & ":" & CStr (LCopyToRow)). Выберите ActiveSheet.Paste 'Переместить счетчик на следующую строку. LCopyToRow = LCopyToRow + 1' Вернитесь к Sheet1, чтобы продолжить поиск листов ("Sheet1"). Выберите End If, если LSearchRow = LSearchRow + 1 Wend 'Положение в ячейке A109 Application.CutCopyMode = False Range ("A109"). Выберите MsgBox "Все соответствующие данные были скопированы." Exit Sub Err_Execute: MsgBox "Произошла ошибка." End Sub

Решение

Я даю два макроса "тест" и "отменить"

образец листа такой (лист1) - сортировать не нужно

дата data1 data2

01.03.2010 37 1

02.03.2010 65 96

3/3/2010 48 46

3/2/2010 78 54

3/5/2010 3 38

3/2/2010 83 58

3/3/2010 45 78

попробуй макрос "тест" и посмотри лист2

если хочешь перепроверить

1. запустить "отменить"

затем

2.rung "тест"

макросы

 Под тест () Dim r As Range, r1 As Range, r2 As Range Dim c2 As Range, cfind As Range Sheet ("sheet1"). Активируйте Set r = Range (Range ("A1"), Range ("A1") .End (xlDown)) Set r1 = Range ("a1"). End (xlDown) .Offset (5, 0) r.AdvancedFilter action: = xlFilterCopy, copytorange: = r1, уникальное: = True Set r2 = Range (r1 .Offset (1, 0), r1.End (xlDown)) Для каждого c2 в r2 Если WorksheetFunction.CountIf (r, c2)> 1, то с диапазоном («A1»). Поле CurrentRegion .AutoFilter: = 1, критерии1: = c2.Value .Cells.SpecialCells (xlCellTypeVisible). Копии рабочих листов ("sheet2"). Ячейки (Rows.Count, "A"). End (xlUp) .Offset (1, 0) .PasteSpecial Заканчивается End End ActiveSheet. AutoFilterMode = False Next c2 Worksheets ("sheet2"). Активировать Do Set cfind = ActiveSheet.Cells.Find (what: = "date", lookat: = xlWhole, after: = Range ("A2")) Если cfind - это ничто, то Выход Do cfind.EntireRow.Delete Рабочие листы цикла ("sheet1"). Диапазон ("A1"). Таблицы целиком. Копия ("sheet2"). Диапазон ("A1"). PasteSpecial Application.CutCopyMode = False End Sub Sub undo ( ) Рабочие листы ("sheet2"). Ячейки. Clear End Sub