Excel - Makro pro vytvoření nového sešitu a kopírování dat
Problém
Hledám makro pro kopírování řádků na základě částečného obsahu buněk ve sloupci. Mám Excel tabulku s názvem "arc.xlsx", ze kterého bych chtěl kopírovat data do dalších několika nových souborů Excel, když jsou splněna určitá kritéria. Umístění souboru Excel je C: Dokumenty a nastavení xxxx Desktop Společnost. Jsem jen začátečník v aplikaci Excel.
Níže je ukázka arc.xlsx
GP BR CUST_NO CUST_NAME den mo roku I1 01 999999 SMITH 00 08 09 I1 ab 999999 SMITH 04 08 09 I1 cd 999999 SMITH 04 10 09 I1 01 999999 SMITH 04 01 10 I1 02 999999 SMITH 27 02 10 I1 01 999999 SMITH 27 02 10 I1 01 999999 SMITH 27 02 10 I1 cd 999999 SMITH 02 03 10 I1 cd 999999 SMITH 04 03 10 I1 cd 999999 SMITH 30 07 09 I1 ab 999999 SMITH 30 07 09 I1 02 999999 SMITH 30 07 09
- Chtěl bych, aby makro kopírovalo řádky, které mají ve sloupci B písmeno „ab“ (s názvem BR) a uložte je do nového souboru Excel s názvem ab.xlsx ve stejné složce umístění.
- Stejně tak pro 'cd', '01' a '02' uložením dat do souborů s názvem cd.xlsx, 01.xlsx tak dále.
Řešení
1. ULOŽTE ZÁLOHU VAŠEHO PRÁCE
2. Otevřete pracovní knihu
3. Stiskněte klávesy ALT + F11 (současně klávesy ALT a klávesy F11). Otevřete VBE
4. V menu VBE klikněte na Vložit a poté na Modul klikněte na něj. Otevře se prázdný modul
5. Zkopírujte kód po instrukcích výběrem kódu (bude nalezen za instrukcemi) a stisknutím kláves CTRL + C (obě klávesy současně)
6. Vložte kód do nově přidaného modulu (viz krok 4) klepnutím na modul a stisknutím kláves CTRL + V (opět obě současně)
7. Ujistěte se, že v vloženém kódu není žádná červená čára.
8. Stisknutím klávesy F5 spusťte makro.
9 Zkontrolujte dokumenty ve výchozím umístění, kam soubor obecně uloží.
ZDE JE KÓD
Dílčí detaily () Dim thisWB As String Dim newWB As String thisWB = ActiveWorkbook.Name Při chybě Resume Next Sheets ("tempsheet") Delete On Error GoTo 0 Sheets.Add ActiveSheet.Name = "tempsheet" Listy ("Sheet1"). Vyberte Pokud ActiveSheet.AutoFilterMode pak Cells.Select na Chyba Pokračovat Další ActiveSheet.ShowAllData On Chyba GoTo 0 End If Columns ("B: B") Vyberte Selection.Copy listy ("tempsheet") Vyberte rozsah ("A1"). Vyberte ActiveSheet.Paste Application.CutCopyMode = False If (Buňky (1, 1) = "") Pak lastrow = Buňky (1, 1) .End (xlDown) .Row Pokud lastrow Rows.Count pak Range ("A1: A" & lastrow - 1) .Vybrat Selection.Delete Shift: = xlUp End If End If Columns ("A: A") Vyberte sloupce ("A: A") AdvancedFilter Akce: = xlFilterCopy, _ CopyToRange: = Rozsah (" B1 "), Unique: = True Columns (" A: A "). Smazat buňky.Vybrat Selection.Sort _ Key1: = Range (" A2 "), Order1: = xlAscending, _ Header: = xlYes, OrderCustom: = 1, _ MatchCase: = False, Orientace: = xlTopToBottom, _ DataOption1: = xlSortNormal lMaxSupp = Buňky (Rows.Count, 1) .End (xlUp) .Row pro s uppno = 2 Pro lMaxSupp Windows (thisWB) .Activate supName = Listy ("tempsheet") Rozsah ("A" & suppno) Pokud supName "" Pak Workbooks.Add ActiveWorkbook.SaveAs supName newWB = ActiveWorkbook.Name Windows (thisWB). Aktivovat listy ("List1") Vyberte Cells.Select Pokud ActiveSheet.AutoFilterMode = False pak Selection.AutoFilter End Pokud pole Selection.AutoFilter: = 2, Kritéria1: = "=" & supName, _ Operátor: = xlAnd, Kritéria2: = "" lastrow = Buňky (Rows.Count, 2) .End (xlUp) .Row řádky ("1:" & lastrow). Kopírovat Windows (newWB) .Aktivovat ActiveSheet.Paste ActiveWorkbook.Save ActiveWorkbook.Close End If Next Sheets ( Odstranit listy ("List1"). Vyberte Pokud ActiveSheet.AutoFilterMode pak Cells.Select ActiveSheet.ShowAllData End If End Sub Díky Rizvisa1 za tento tip.