Excel - Membuat makro untuk mencari dan menyalin

Isu

Saya memiliki spreadsheet dengan semua tanggal berbeda dengan data terkait di barisnya. Ada banyak baris dengan tanggal yang sama dan saya ingin membuat makro untuk mencari semua tanggal yang sama dan salin dan tempel ke lembar 2 sehingga saya bisa mengaturnya

contoh:

 27-Sep 27-Sep 27-Sep 28-Sep 28-Sep 01-Okt 01-Okt

Saya tidak tahu bagaimana cara membuat makro namun saya telah mencari di seluruh internet untuk menemukan satu yang bisa saya modifikasi untuk memasukkan data saya sendiri, dan inilah yang saya hasilkan.

 Sub SearchForString () Dim LSearchRow Sebagai Integer Dim LCopyToRow Sebagai Integer Pada Kesalahan GoTo Err_Execute 'Mulai pencarian di baris 6 LSearchRow = 6' Mulai menyalin data ke baris 110 di Sheet2 (variabel penghitung baris) LCopyToRow = 110 Sementara Len (Rentang ("A" & CStr (LSearchRow)). Nilai)> 0 'Jika nilai dalam kolom A = "27-Sep", salin seluruh baris ke Sheet2 Jika Rentang ("A" & CStr (LSearchRow)). Nilai = "27 = Sep" Kemudian 'Pilih baris dalam Sheet1 untuk menyalin Baris (CStr (LSearchRow) & ":" & CStr (LSearchRow)). Pilih Pilihan. Salin' Tempel baris ke Sheet2 di baris berikutnya Lembar ("Sheet2"). Pilih Baris (CStr (LCopyToRow) & ":" & CStr (LCopyToRow)). Pilih ActiveSheet.Paste 'Pindahkan penghitung ke baris berikutnya LCopyToRow = LCopyToRow + 1' Kembali ke Sheet1 untuk melanjutkan mencari Sheets ("Sheet1"). Pilih End If LSearchRow = LSearchRow + 1 Wend 'Posisikan pada sel A109 Application.CutCopyMode = False Range ("A109"). Pilih MsgBox "Semua data yang cocok telah disalin." Keluar Sub Err_Execute: MsgBox "Terjadi kesalahan." End Sub

Larutan

Saya memberikan dua makro "tes" dan "undo"

lembar sampel seperti ini (sheet1) -tidak perlu disortir

data tanggal1 data2

3/1/2010 37 1

3/2/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

coba "tes" makro dan lihat sheet2

jika Anda ingin menguji ulang

1. run "undo"

kemudian

2. mulai "tes"

makro adalah

 Sub test () Rentang Dim r As, R1 Sebagai Rentang, r2 Sebagai Rentang Dim c2 Sebagai Rentang, cfind Sebagai Rentang Lembar Kerja ("sheet1"). Aktifkan Set r = Rentang (Rentang ("A1"), Rentang ("A1") .End (xlDown)) Setel r1 = Rentang ("a1"). Akhir (xlDown) .Offset (5, 0) r.AdvancedFilter action: = xlFilterCopy, copytorange: = r1, unik: = True Set r2 = Range (r1 .Offset (1, 0), r1.End (xlDown)) Untuk Setiap c2 Dalam r2 Jika WorksheetFunction.CountIf (r, c2)> 1 Kemudian Dengan Rentang ("A1") .Region Saat Ini .Laporan Bidang AutoFilter: = 1, Kriteria1: = c2.Value .Cells.SpecialCells (xlCellTypeVisible) .Copy Worksheets ("sheet2"). Cells (Rows.Count, "A"). End (xlUp) .Offset (1, 0) .PasteSpecial End With End Jika ActiveSheet. AutoFilterMode = Salah Selanjutnya Lembar Kerja c2 ("sheet2"). Aktifkan Do Set cfind = ActiveSheet.Cells.Find (what: = "date", lookat: = xlWhole, after: = Range ("A2")) Jika cfind tidak ada artinya Keluar Lakukan cfind.EntireRow.Delete Loop Worksheets ("sheet1"). Range ("A1"). KeseluruhanRow.Copy Worksheets ("sheet2"). Range ("A1"). PasteAplikasi Khusus.CutCopyMode = False End Sub Sub undo ( ) Lembar kerja ("sheet2"). Sel. Kosongkan Sub