Excel - Makro na vytvorenie nového zošita a kopírovanie dát
Problém
Hľadám makro kopírovať riadky na základe čiastočného obsahu buniek v stĺpci. Mám tabuľku Excel s názvom "arc.xlsx", z ktorej by som chcel skopírovať dáta do ďalších niekoľkých nových súborov programu Excel, keď sú splnené určité kritériá. Umiestnenie súboru programu Excel je C: Dokumenty a nastavenia xxxx Desktop Spoločnosť. Som len začiatočník v programe Excel.
Nižšie je vzorka arc.xlsx
GP BR CUST_NO CUST_NAME deň po 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
- Chcel by som, aby makro kopírovalo riadky, ktoré majú v stĺpci B znak „ab“ (s názvom BR) a uložte ho do nového súboru programu Excel s názvom ab.xlsx v rovnakom priečinku umiestnenia.
- A rovnako pre 'cd', '01' a '02' uložením dát do súborov s názvom cd.xlsx, 01.xlsx tak ďalej.
Riešenie
1. ULOŽTE ZÁLOHU VAŠEJ PRÁCE
2. Otvorte pracovný zošit
3. Stlačte klávesy ALT + F11 (súčasne kláves ALT aj kláves F11). Otvorí sa VBE
4. V menu VBE kliknite na Insert a potom kliknite na Module. Otvorí sa prázdny modul
5. Skopírujte kód dajte po pokynoch výberom kódu (nájde sa za inštrukciami) a stlačením klávesov CTRL + C (obidva klávesy súčasne)
6. Vložte kód do novo pridaného modulu (pozri krok 4) kliknutím na modul a stlačením klávesov CTRL + V (opäť obidva naraz)
7. Skontrolujte, či v vloženom kóde nie je červená čiara.
8. Stlačením klávesu F5 spustite makro.
9 Skontrolujte dokumenty v predvolenom umiestnení, kam sa súbor Excel uloží.
TU JE KÓD
Sub detaily () Dim thisWB As String Dim NewWB As String thisWB = ActiveWorkbook.Name Pri chybe Pokračovať ďalšie hárky ("tempsheet") Delete On Error GoTo 0 Sheets.Add ActiveSheet.Name = "tempsheet" Sheets ("Sheet1"). Vyberte Ak ActiveSheet.AutoFilterMode Potom Cells.Select na Chyba Resume Next 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 (Bunky (1, 1) = "") Potom lastrow = Bunky (1, 1) .End (xlDown) .Row Ak lastrow Rows.Count potom Range ("A1: A" & lastrow - 1) .Vybrať Selection.Delete Shift: = xlUp End If End If Columns ("A: A") Vyberte stĺpce ("A: A") AdvancedFilter Akcia: = xlFilterCopy, _ CopyToRange: = Range (" B1 "), Unique: = True Columns (" A: A "). Vymazať bunky. Vyberte Selection.Sort _ Key1: = Range (" A2 "), Order1: = xlAscending, _ Header: = xlYes, OrderCustom: = 1, _ MatchCase: = False, Orientácia: = xlTopToBottom, _ DataOption1: = xlSortNormal lMaxSupp = Bunky (Rows.Count, 1) .End (xlUp) .Row pre s uppno = 2 Na lMaxSupp Windows (thisWB) .Activate supName = Sheets ("tempsheet") Rozsah ("A" & suppno) Ak supName "" Potom Workbooks.Add ActiveWorkbook.SaveAs supName newWB = ActiveWorkbook.Name Windows (thisWB). Aktivovať listy ("List1") Vyberte Cells.Select Ak ActiveSheet.AutoFilterMode = False Potom Selection.AutoFilter End Ak Selection.AutoFilter Pole: = 2, Kritérium1: = "=" & supName, _ Operátor: = xlAnd, Kritérium2: = "" lastrow = Bunky (Rows.Count, 2) .End (xlUp) .Row riadky ("1:" & lastrow) .Kopírovať Windows (newWB) .Aktivovať ActiveSheet.Paste ActiveWorkbook.Save ActiveWorkbook.Close End If Next Sheets ( Vymazať listy ("List1") Vyberte Ak ActiveSheet.AutoFilterMode potom Cells.Select ActiveSheet.ShowAllData End If End Sub Vďaka Rizvisa1 za tento tip.