Excel - makro za razvrščanje več listov

Težava

Imam 11 listov v Excelu. 10 listov mora potegniti podatke iz lista1.

To je za kuharje v gostinski ponudbi.

V stolpcu A imam ključno besedo za razlikovanje med vrsticami informacij.

Kar potrebujem je ...

• List 2 in 3 povlecita celotno vrstico iz lista 1, če je beseda v stolpcu A "vroča".
• List 4 in 5 povlecite celotno vrstico iz lista 1, če je beseda v stolpcu A "hladna".
• List 6 izvlecite celotno vrstico iz lista 1, če je beseda v stolpcu A "Bulk".
• List 8 in 9 potegne celotno vrstico iz lista 1, če je beseda v stolpcu A "Pecivo".
• List 10 izvlecite celotno vrstico iz lista 1, če je beseda v stolpcu A "Pres".

Drugi listi so že zajeti.

Ustvaril sem makro za razvrščanje listov na podlagi treh stolpcev. Lepo bi bilo, če bi ta makro samodejno zagnal vse informacije, ki so bile dodane listu. Ne na določeno linijo, temveč na katerokoli območje lista, da se informacije ohranijo v redu.

Rešitev

Poskusite ta makro:

 Možnost Eksplicitna zasebna poddelavnica_premenitev (spreminjanje cilja kot ByVal) Dim nxtRow Kot Integer 'Določite, ali je bila sprememba v stolpcu H (8) Če Target.Column = 8 Potem' Če da, določite, ali je celica = vroča če je Target.Value = "H" Potem 'Če Da, poiščite naslednjo prazno vrstico v Listu 2 nxtRow = Listi (2) .Range ("G" & Rows.Count). End (xlUp) .Row + 1' Kopiraj spremenjeno vrstico in prilepi v Sheet 2 Target.EntireRow .Kopiraj _ Cilj: = Listi (2) .Range ("A" & nxtRow) "Če je odgovor pritrdilen, poiščite naslednjo prazno vrstico v Listu 3 nxtRow = Sheets (3) .Range (" G "& Rows.Count) .End ( xlUp) .Row + 1 'Kopiraj spremenjeno vrstico in prilepi v Sheet 3 Target.EntireRow.Copy _ Destination: = Sheets (3) .Range ("A" & nxtRow) End if End If "Določi, ali je bila sprememba v stolpcu H ( 8) Če Target.Column = 8 Potem 'Če da, ugotovite, ali je celica = Cold Če Target.Value = "C" Potem "Če Da, poiščite naslednjo prazno vrstico v Listu 4 nxtRow = Listi (4) .Range (" G ") & Rows.Count) .End (xlUp) .Row + 1 'Kopiraj spremenjeno vrstico in prilepi v Sheet 4 Target.EntireRow.Copy _ Destination: = Sheets (4) .Range ("A" & nxtRow)' Če je odgovor Da, poiščite naslednja prazna vrstica v Listu 5 nxtRow = Listi (5) .Range ("G" & Rows.Count) .End (xlUp) .Row + 1 'Kopiraj spremenjeno vrstico in prilepi v Sheet 3 Target.EntireRow.Copy _ Destination: = Listi (5) .Range ("A" & nxtRow) End If End Če "Določite, ali je bila sprememba v stolpcu H (8) Če Target.Column = 8, potem" Če da, določite, če je celica = predstavitev Če Target.Value = " P "Potem" Če je odgovor pritrdilen, poiščite naslednjo prazno vrstico v listu 8 nxtRow = listi (8) .Range ("G" & Rows.Count). End (xlUp) .Row + 1 'Kopiraj spremenjeno vrstico in prilepi v Sheet 8 Target .EntireRow.Copy _ Destination: = Sheets (8) .Range ("A" & nxtRow) End If End Če "Določite, ali je bila sprememba v stolpcu H (8) Če Target.Column = 8, potem" Če da, določite, če je celica = Pecivo Če Target.Value = "PY" Potem "Če Da, poiščite naslednjo prazno vrstico v Listu 10 nxtRow = Listi (10) .Range (" G "& Rows.Count) .End (xlUp) .Row + 1 'Copy spremenjena vrstica in prilepi v list 10 Target.EntireRow.Copy _ Destination: = listi (10) .Range ("A" & nxtRow) "Če da, poiščite naslednjo prazno vrstico v listu 12 nxtRow = listi (11) .Range (" G "& Rows.Count). End (xlUp) .Row + 1 'Kopiraj spremenjeno vrstico in prilepi v Sheet 12 Target.EntireRow.Copy _ Destination: = Sheets (11) .Range ("A" & nxtRow) End If End If "Določi, ali je bila sprememba v stolpcu H (8) Če Target.Column = 8 Potem "Če da, določite, če je celica = večja, če Target.Value =" B "Potem" Če je odgovor Da, poiščite naslednjo prazno vrstico v Listu 6 nxtRow = Sheets (6) .Range ("G "& Rows.Count) .End (xlUp) .Row + 1" Kopiraj spremenjeno vrstico in prilepi v Sheet 6 Target.EntireRow.Copy _ Destination: = Sheets (6) .Range ("A" & nxtRow) End if End End Sub 

Hvala Jlee1978 za ta nasvet.