Copiere dintr-un sheet in toate celelalte

[Bianca Maria]

Buna ziua!

Problema mea este urmatoarea: am un tabel cu n linii si m coloane, care se gaseste in sheet-ul 1 pe care l-am redenumit "Registru". Folosind un cod VBA, am generat automat, pentru fiecare linie din tabel cate un alt sheet.
In fiecare sheet nou as vrea sa existe:
1. capul de tabel din "Registru" - pe prima linie;
2. linia din tabel corespunzatoare sheet-ului - pe cea de-a II-a linie.
Am atasat o imagine cu tabelul din care vreau sa extrag fiecare linie pe un sheet diferit.

Va multumesc!

[IPP]

Buna ziua

(Mai ales) atunci cand e vorba despre macro e esential de lucrat cu fisier exemplu plus specificatii clare pentru ca exista probabilitate mare ca realitatea sa determine alte abordari sau limitari, de la un nume din prea multe caractere pentru o foaie pana la existenta unor formule in tabel (sau lista?) care sa provoce neplaceri daca se foloseste un simplu copy/paste sau formatari conditionate care nu sunt necesare la destinatie.

In plus, trebuie sa stiti ca nu toata lumea are timp sa reproduca situatia din fisierul dvs.

Pornind de la selectia range-ului care contine viitorul nume al foii, codul de mai jos face urmatoarele:

-genereaza cate o foaie pentru fiecare inregistrare (rand) care are completata informatia, foaie ce e plasata la sfarsit si avand numele celulei din selectie (daca acel nume contine caractere interzise va apare o eroare)
-copiaza in fiecare foaie nou creata capul de lista din Sheet1 si randul de interes

Codul nu trateaza situatiile in care foaia sursa e redenumita (trebuie sa fie "Sheet1" sau editat codul) sau deja exista o foaie cu acelasi nume.

Cod: Selectaţi tot

Sub GenShs()

Dim shName As String

Application.ScreenUpdating = False

For Each c In Selection
 If c <> "" Then
  shName = c.Value
  With ThisWorkbook
  .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = shName
  End With
  Sheets("Sheet1").Range("A6").EntireRow.Copy Destination:=Sheets(shName).Range("A6")
  c.EntireRow.Copy Destination:=Sheets(shName).Range("A7")
 End If

Next c

Application.ScreenUpdating = False

End Sub

Testati pe o copie a fisierului original!!

IP