Witam wszystkich. Potrzebuję napisać macro, w którym: 1. Z Arkusza początkowego kopiuje wartości (nazwy dostawców) do osobnego Arkusza. 2. Przycina te wartości do wskazanej ilości znaków (tak, żeby mogły stanowić nazwę Arkusza). 3. Otrzymany wynik zwraca do pierwszego Arkusza w miejsce oryginalnych wartości. 4. Wracamy do nowego arkusza, w którym nazwy były przycinane i usuwamy duplikaty. 5. Zliczamy ile mam dostawców i tworzymy tyle nowych Arkuszy. 6. Kazdy Arkusz nazywamy nazwą dostawcy. 7. Usuwamy Arkusz pomocniczy. Do tego momentu udało mi się to zrobić 8. Przeszukujemy Arkusz pierwszy po kolumnie z nazwą dostawcy. 9. Jeśli znajdzie takiego dostawcę w którym nazwa zgadza się z nazwą Arkusza, wkleja cały wiersz do wskazanego Arkusza... i tu mam problem. Bardzo Was proszę o pomoc bo jest świeży w tym temacie.
Attribute VB_Name = " Module1 "
Sub Punch_Out()
Attribute Punch_Out.VB_ProcData.VB_Invoke_Func = " \n14 "
' Punch_Out Macro
' Skracanie nazwy vendora
Columns( " C:C " ).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Application.CutCopyMode = False
Do While ActiveCell.Value & lt; & gt; Empty
ActiveCell.Value = Left(ActiveCell.Value, 27)
ActiveCell.Offset(1, 0).Select
Loop
Columns( " A:A " ).Select
Selection.Copy
Sheets( " Data Input " ).Select
ActiveSheet.Paste
' Usuniecie dupliaktow vendorow
Sheets(2).Select
Columns( " A:A " ).Select
Application.CutCopyMode = False
ActiveSheet.Range( " A:A " ).RemoveDuplicates Columns:=1, Header:=xlNo
N = Application.WorksheetFunction.CountA(Range( " A:A " )) - 1
Dim WkSht As Integer
WkSht = 0
Do While WkSht & lt; N
Sheets.Add Before:=ActiveSheet
WkSht = WkSht + 1
Loop
' Nazwanie Arkuszy
Sheets(N + 2).Activate
Range( " A2 " ).Activate
For f = 2 To (N + 1)
Application.Worksheets(f).Name = Application.Cells(f, 1).Value
Next f
Application.DisplayAlerts = False
Sheets(N + 2).Delete
' Kopiowanie do Arkuszy
Sheets(1).Activate
Range( " C2 " ).Select
Dim Vendor As String
Do While ActiveCell.Value & lt; & gt; Empty
Vendor = ActiveCell.Value
ActiveCell.EntireRow.Select
K = 0
For f = 2 To N + 1
If Sheets(f).Name = Vendor Then
K = f
Exit For
Else
End If
Next f
Selection.Copy Destination:=Sheets(K).Range( " A1 " )
ActiveCell.Offset(1, 0).Select
Loop
End Sub