VBA.Mania

Sub Nowe_pliki()
    Dim index As String
    Dim ile As Long
    Dim i As Long
    Application.ScreenUpdating = False
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    ' Przy pomocy filtra zaawansowanego kopiuje nie powtarzające się dane do ostatniej kolumny
    Range("A2:A7000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
    ("A2:A7000"), CopyToRange:=Range("IV2"), Unique:=True
    ile = Application.CountA(Range(Cells(1, 256), Cells(7000, 256))) + 1
    Range("iu2") = ile
    'Póżniej na podstawie tych danych twoże nowe pliki
    For i = 2 To ile
        Range(Cells(i, 256), Cells(i, 256)).Activate
        index = ActiveCell.Value
        Workbooks.Add
        ActiveWorkbook.SaveAs Filename:="C:\" & index & ".xls"
        ActiveWorkbook.Close
        Workbooks("duży").Activate
    Next i

    Rows("1:1").Delete
    Selection.Delete Shift:=xlUp
    Columns("IU:IV").ClearContents
    Application.ScreenUpdating = True

End Sub

Sub wyślij()
    Dim index As String
    Dim bz As Long
    Dim ile As Long
    Dim i As Long
    Dim koniec As Long

    Application.ScreenUpdating = False
    Range("A1:A7000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
                     ("A1:A7000"), CopyToRange:=Range("IV1"), Unique:=True
    ile = Application.CountA(Range(Cells(1, 256), Cells(7000, 256)))
    Range("iu1") = ile

    For i = 1 To ile
        koniec = 1

        Range(Cells(i, 256), Cells(i, 256)).Activate
        index = ActiveCell.Text
        Workbooks.Open Filename:="c:\" & index & ".xls"

        Do
            Workbooks("duży").Activate

            Range(Cells(koniec, 1), Cells(koniec, 1)).Activate
            If ActiveCell.Text = "" Then Exit Do
            If ActiveCell.Text = index Then

                Range(Cells(koniec, 1), Cells(koniec, 254)).Copy
                Workbooks(index).Activate
                Worksheets("arkusz1").Activate

                bz = 1
                Do While Cells(bz, 1) <> ""
                    bz = bz + 1
                Loop

                Worksheets("arkusz1").Range(Cells(bz, 1), Cells(bz, 1)).Activate
                ActiveCell.PasteSpecial
            End If

            Workbooks("duży").Activate
            koniec = koniec + 1
        Loop

        Workbooks(index).Activate
        Columns("a:b").Select
        Selection.NumberFormat = "m/d/yyyy"
        ActiveWorkbook.Save
        ActiveWindow.Close
    Next i

    Application.ScreenUpdating = False

End Sub