Я учусь VBA, помогите написать макрос

[Ironochka]

Помогите написать макрос, который переносит строки из исходного листа , по значению одной из колонок , в отдельные листы, названные также ,как это значение из колонки исходного листа

[AndyF]

Так помочь? или написать?

[Ironochka]

Код есть , но длинный, с повторами. Только начинаю постигать азы VBA, буду благодарна за помощь. Приложу код

Код Выделить Развернуть

Option Explicit

Sub ReestrY()

    'лист итоговый
    Dim ws As Worksheet
    Set ws = Worksheets("Все факты")
       
    'лист 0425.000001
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("0425.000001")
   
    'лист 0643.000001
    Dim ws2 As Worksheet
    Set ws2 = Worksheets("0643.000001")
   
    'лист 0667.000001
    Dim ws3 As Worksheet
    Set ws3 = Worksheets("0667.000001")
   
    'лист 0987.000001
    Dim ws4 As Worksheet
    Set ws4 = Worksheets("0987.000001")
   
    'лист 0991.000001
    Dim ws5 As Worksheet
    Set ws5 = Worksheets("0991.000001")
   
   
    'лист 1659.000001
    Dim ws6 As Worksheet
    Set ws6 = Worksheets("1659.000001")
   
    'лист 1670.000001
    Dim ws7 As Worksheet
    Set ws7 = Worksheets("1670.000001")
   
    'лист 1896.000001
    Dim ws8 As Worksheet
    Set ws8 = Worksheets("1896.000001")
   
    'лист 2222.000001
    Dim ws9 As Worksheet
    Set ws9 = Worksheets("2222.000001")
   
    'лист 2359.000001
    Dim ws10 As Worksheet
    Set ws10 = Worksheets("2359.000001")
   
    'лист 2374.000001
    Dim ws11 As Worksheet
    Set ws11 = Worksheets("2374.000001")
   
    'лист 2387.000001
    Dim ws12 As Worksheet
    Set ws12 = Worksheets("2387.000001")
   
    'лист 2466.000000
    Dim ws13 As Worksheet
    Set ws13 = Worksheets("2466.000000")
   
    'лист 2488.000001
    Dim ws14 As Worksheet
    Set ws14 = Worksheets("2488.000001")
   
    'лист 2511.000001
    Dim ws15 As Worksheet
    Set ws15 = Worksheets("2511.000001")
   
   
    'лист 2818.000001
    Dim ws16 As Worksheet
    Set ws16 = Worksheets("2818.000001")
   
   
   
    'лист 2961.000001
    Dim ws17 As Worksheet
    Set ws17 = Worksheets("2961.000001")
   
    'лист 2966.000001
    Dim ws18 As Worksheet
    Set ws18 = Worksheets("2966.000001")
   
    'лист 3005.000001
    Dim ws19 As Worksheet
    Set ws19 = Worksheets("3005.000001")
   
     'лист 9866.000001
    Dim ws20 As Worksheet
    Set ws20 = Worksheets("9866.000001")
   
     'лист 9871.000001
    Dim ws21 As Worksheet
    Set ws21 = Worksheets("9871.000001")
   
       
    'лист A470.000001
    Dim ws22 As Worksheet
    Set ws22 = Worksheets("A470.000001")
   
   
    'лист A513.000001
    Dim ws23 As Worksheet
    Set ws23 = Worksheets("A513.000001")
   
   
    'лист A586.000001
    Dim ws24 As Worksheet
    Set ws24 = Worksheets("A586.000001")
   
    'лист A592.000001
    Dim ws25 As Worksheet
    Set ws25 = Worksheets("A592.000001")
       
    'лист A777.000001
    Dim ws26 As Worksheet
    Set ws26 = Worksheets("A777.000001")
   
   
    'лист B027.000001
    Dim ws27 As Worksheet
    Set ws27 = Worksheets("B027.000001")
           
       
    'текущая строка на листе Все факты
    Dim r As Long
    r = 2
   
    'текущая строка на листе
    Dim i1 As Long
    i1 = 2
   
    'текущая строка на листе
    Dim i2 As Long
    i2 = 2
   
    'текущая строка на листе
    Dim i3 As Long
    i3 = 2
   
    'текущая строка на листе
    Dim i4 As Long
    i4 = 2
   
    'текущая строка на листе
    Dim i5 As Long
    i5 = 2
   
    'текущая строка на листе
    Dim i6 As Long
    i6 = 2
   
    'текущая строка на листе
    Dim i7 As Long
    i7 = 2
   
    'текущая строка на листе
    Dim i8 As Long
    i8 = 2
   
    'текущая строка на листе
    Dim i9 As Long
    i9 = 2
   
    'текущая строка на листе
    Dim i10 As Long
    i10 = 2
   
    'текущая строка на листе
    Dim i11 As Long
    i11 = 2
   
    'текущая строка на листе
    Dim i12 As Long
    i12 = 2
   
    'текущая строка на листе
    Dim i13 As Long
    i13 = 2
   
    'текущая строка на листе
    Dim i14 As Long
    i14 = 2
   
    'текущая строка на листе
    Dim i15 As Long
    i15 = 2
   
    'текущая строка на листе
    Dim i16 As Long
    i16 = 2
   
    'текущая строка на листе
    Dim i17 As Long
    i17 = 2
   
    'текущая строка на листе
    Dim i18 As Long
    i18 = 2
   
    'текущая строка на листе
    Dim i19 As Long
    i19 = 2
   
    'текущая строка на листе
    Dim i20 As Long
    i20 = 2
   
    'текущая строка на листе
    Dim i21 As Long
    i21 = 2
   
    'текущая строка на листе
    Dim i22 As Long
    i22 = 2
   
    'текущая строка на листе
    Dim i23 As Long
    i23 = 2
   
    'текущая строка на листе
    Dim i24 As Long
    i24 = 2
   
    'текущая строка на листе
    Dim i25 As Long
    i25 = 2
   
    'текущая строка на листе
    Dim i26 As Long
    i26 = 2
   
    'текущая строка на листе
    Dim i27 As Long
    i27 = 2
   
           
     ' Очистка листа
    ws1.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws2.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws3.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws4.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws5.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws6.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws7.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws8.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws9.Range("A2:AC1048576").ClearContents
           
    ' Очистка листа
    ws10.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws11.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws12.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws13.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws14.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws15.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws16.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws17.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws18.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws19.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws20.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws21.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws22.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws23.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws24.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws25.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws26.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws27.Range("A2:AC1048576").ClearContents
       
 
    Application.ScreenUpdating = False
   
    While ws.Cells(r, 1) <> ""
        Dim kodPI As String
        kodPI = ws.Cells(r, 2).Text
               
        If kodPI = "0425.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws1.Range("A" & i1 & ":F" & i1) = ws.Range("A" & r & ":F" & r).Value
            i1 = i1 + 1
        End If
       
       
        If kodPI = "0643.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws2.Range("A" & i2 & ":F" & i2) = ws.Range("A" & r & ":F" & r).Value
            i2 = i2 + 1
        End If
             
       
        If kodPI = "0667.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws3.Range("A" & i3 & ":F" & i3) = ws.Range("A" & r & ":F" & r).Value
            i3 = i3 + 1
        End If
       
        If kodPI = "0987.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws4.Range("A" & i4 & ":F" & i4) = ws.Range("A" & r & ":F" & r).Value
            i4 = i4 + 1
        End If
       
        If kodPI = "0991.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws5.Range("A" & i5 & ":F" & i5) = ws.Range("A" & r & ":F" & r).Value
            i5 = i5 + 1
        End If
       
        If kodPI = "1659.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws6.Range("A" & i6 & ":F" & i6) = ws.Range("A" & r & ":F" & r).Value
            i6 = i6 + 1
        End If
       
        If kodPI = "1670.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws7.Range("A" & i7 & ":F" & i7) = ws.Range("A" & r & ":F" & r).Value
            i7 = i7 + 1
        End If
       
        If kodPI = "1896.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws8.Range("A" & i8 & ":F" & i8) = ws.Range("A" & r & ":F" & r).Value
            i8 = i8 + 1
        End If
       
        If kodPI = "2222.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws9.Range("A" & i9 & ":F" & i9) = ws.Range("A" & r & ":F" & r).Value
            i9 = i9 + 1
        End If
       
        If kodPI = "2359.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws10.Range("A" & i10 & ":F" & i10) = ws.Range("A" & r & ":F" & r).Value
            i10 = i10 + 1
        End If
       
        If kodPI = "2374.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws11.Range("A" & i11 & ":F" & i11) = ws.Range("A" & r & ":F" & r).Value
            i11 = i11 + 1
        End If
       
        If kodPI = "2387.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws12.Range("A" & i12 & ":F" & i12) = ws.Range("A" & r & ":F" & r).Value
            i12 = i12 + 1
        End If
       
        If kodPI = "2466.000000" Then
            'Call WriteRow(ws, r, ws1, i)
            ws13.Range("A" & i13 & ":F" & i13) = ws.Range("A" & r & ":F" & r).Value
            i13 = i13 + 1
        End If
       
        If kodPI = "2488.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws14.Range("A" & i14 & ":F" & i14) = ws.Range("A" & r & ":F" & r).Value
            i14 = i14 + 1
        End If
       
        If kodPI = "2511.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws15.Range("A" & i15 & ":F" & i15) = ws.Range("A" & r & ":F" & r).Value
            i15 = i15 + 1
        End If
       
        If kodPI = "2818.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws16.Range("A" & i16 & ":F" & i16) = ws.Range("A" & r & ":F" & r).Value
            i16 = i16 + 1
        End If
       
        If kodPI = "2961.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws17.Range("A" & i17 & ":F" & i17) = ws.Range("A" & r & ":F" & r).Value
            i17 = i17 + 1
        End If
       
        If kodPI = "2966.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws18.Range("A" & i18 & ":F" & i18) = ws.Range("A" & r & ":F" & r).Value
            i18 = i18 + 1
        End If
       
        If kodPI = "3005.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws19.Range("A" & i19 & ":F" & i19) = ws.Range("A" & r & ":F" & r).Value
            i19 = i19 + 1
        End If
       
       
        If kodPI = "9866.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws20.Range("A" & i20 & ":F" & i20) = ws.Range("A" & r & ":F" & r).Value
            i20 = i20 + 1
        End If
       
        If kodPI = "9871.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws21.Range("A" & i21 & ":F" & i21) = ws.Range("A" & r & ":F" & r).Value
            i21 = i21 + 1
        End If
                 
       
        If kodPI = "A470.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws22.Range("A" & i22 & ":F" & i22) = ws.Range("A" & r & ":F" & r).Value
            i22 = i22 + 1
        End If
       
        If kodPI = "A513.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws23.Range("A" & i23 & ":F" & i23) = ws.Range("A" & r & ":F" & r).Value
            i23 = i23 + 1
        End If
       
        If kodPI = "A586.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws24.Range("A" & i24 & ":F" & i24) = ws.Range("A" & r & ":F" & r).Value
            i24 = i24 + 1
        End If
       
        If kodPI = "A592.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws25.Range("A" & i25 & ":F" & i25) = ws.Range("A" & r & ":F" & r).Value
            i25 = i25 + 1
        End If
       
        If kodPI = "A777.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws26.Range("A" & i26 & ":F" & i26) = ws.Range("A" & r & ":F" & r).Value
            i26 = i26 + 1
        End If
               
               
        If kodPI = "B027.000001" Then
            'Call WriteRow(ws, r, ws1, i)
            ws27.Range("A" & i27 & ":F" & i27) = ws.Range("A" & r & ":F" & r).Value
            i27 = i27 + 1
        End If
               
       
       
       
        DoEvents
        r = r + 1
    Wend
   
    Application.ScreenUpdating = True
End Sub


[Ironochka]

ВЗАМЕН

Код Выделить Развернуть

Option Explicit

Sub ReestrY()

    'лист итоговый
    Dim ws As Worksheet
    Set ws = Worksheets("Все факты")
       
    'лист 0425.000001
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("0425.000001")
   
    'лист 0643.000001
    Dim ws2 As Worksheet
    Set ws2 = Worksheets("0643.000001")
   
    'лист 0667.000001
    Dim ws3 As Worksheet
    Set ws3 = Worksheets("0667.000001")
   
    'лист 0987.000001
    Dim ws4 As Worksheet
    Set ws4 = Worksheets("0987.000001")
   
    'лист 0991.000001
    Dim ws5 As Worksheet
    Set ws5 = Worksheets("0991.000001")
   
   
    'лист 1659.000001
    Dim ws6 As Worksheet
    Set ws6 = Worksheets("1659.000001")
   
    'лист 1670.000001
    Dim ws7 As Worksheet
    Set ws7 = Worksheets("1670.000001")
   
    'лист 1896.000001
    Dim ws8 As Worksheet
    Set ws8 = Worksheets("1896.000001")
   
    'лист 2222.000001
    Dim ws9 As Worksheet
    Set ws9 = Worksheets("2222.000001")
   
    'лист 2359.000001
    Dim ws10 As Worksheet
    Set ws10 = Worksheets("2359.000001")
   
    'лист 2374.000001
    Dim ws11 As Worksheet
    Set ws11 = Worksheets("2374.000001")
   
    'лист 2387.000001
    Dim ws12 As Worksheet
    Set ws12 = Worksheets("2387.000001")
   
    'лист 2466.000000
    Dim ws13 As Worksheet
    Set ws13 = Worksheets("2466.000000")
   
    'лист 2488.000001
    Dim ws14 As Worksheet
    Set ws14 = Worksheets("2488.000001")
   
    'лист 2511.000001
    Dim ws15 As Worksheet
    Set ws15 = Worksheets("2511.000001")
   
   
    'лист 2818.000001
    Dim ws16 As Worksheet
    Set ws16 = Worksheets("2818.000001")
   
   
   
    'лист 2961.000001
    Dim ws17 As Worksheet
    Set ws17 = Worksheets("2961.000001")
   
    'лист 2966.000001
    Dim ws18 As Worksheet
    Set ws18 = Worksheets("2966.000001")
   
    'лист 3005.000001
    Dim ws19 As Worksheet
    Set ws19 = Worksheets("3005.000001")
   
     'лист 9866.000001
    Dim ws20 As Worksheet
    Set ws20 = Worksheets("9866.000001")
   
     'лист 9871.000001
    Dim ws21 As Worksheet
    Set ws21 = Worksheets("9871.000001")
   
       
    'лист A470.000001
    Dim ws22 As Worksheet
    Set ws22 = Worksheets("A470.000001")
   
   
    'лист A513.000001
    Dim ws23 As Worksheet
    Set ws23 = Worksheets("A513.000001")
   
   
    'лист A586.000001
    Dim ws24 As Worksheet
    Set ws24 = Worksheets("A586.000001")
   
    'лист A592.000001
    Dim ws25 As Worksheet
    Set ws25 = Worksheets("A592.000001")
       
    'лист A777.000001
    Dim ws26 As Worksheet
    Set ws26 = Worksheets("A777.000001")
   
   
    'лист B027.000001
    Dim ws27 As Worksheet
    Set ws27 = Worksheets("B027.000001")
           
       
    'текущая строка на листе Все факты
    Dim r As Long
    r = 2
   
    'текущая строка на листе
    Dim i1 As Long
    i1 = 2
   
    'текущая строка на листе
    Dim i2 As Long
    i2 = 2
   
    'текущая строка на листе
    Dim i3 As Long
    i3 = 2
   
    'текущая строка на листе
    Dim i4 As Long
    i4 = 2
   
    'текущая строка на листе
    Dim i5 As Long
    i5 = 2
   
    'текущая строка на листе
    Dim i6 As Long
    i6 = 2
   
    'текущая строка на листе
    Dim i7 As Long
    i7 = 2
   
    'текущая строка на листе
    Dim i8 As Long
    i8 = 2
   
    'текущая строка на листе
    Dim i9 As Long
    i9 = 2
   
    'текущая строка на листе
    Dim i10 As Long
    i10 = 2
   
    'текущая строка на листе
    Dim i11 As Long
    i11 = 2
   
    'текущая строка на листе
    Dim i12 As Long
    i12 = 2
   
    'текущая строка на листе
    Dim i13 As Long
    i13 = 2
   
    'текущая строка на листе
    Dim i14 As Long
    i14 = 2
   
    'текущая строка на листе
    Dim i15 As Long
    i15 = 2
   
    'текущая строка на листе
    Dim i16 As Long
    i16 = 2
   
    'текущая строка на листе
    Dim i17 As Long
    i17 = 2
   
    'текущая строка на листе
    Dim i18 As Long
    i18 = 2
   
    'текущая строка на листе
    Dim i19 As Long
    i19 = 2
   
    'текущая строка на листе
    Dim i20 As Long
    i20 = 2
   
    'текущая строка на листе
    Dim i21 As Long
    i21 = 2
   
    'текущая строка на листе
    Dim i22 As Long
    i22 = 2
   
    'текущая строка на листе
    Dim i23 As Long
    i23 = 2
   
    'текущая строка на листе
    Dim i24 As Long
    i24 = 2
   
    'текущая строка на листе
    Dim i25 As Long
    i25 = 2
   
    'текущая строка на листе
    Dim i26 As Long
    i26 = 2
   
    'текущая строка на листе
    Dim i27 As Long
    i27 = 2
   
           
     ' Очистка листа
    ws1.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws2.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws3.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws4.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws5.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws6.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws7.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws8.Range("A2:AC1048576").ClearContents

     ' Очистка листа
    ws9.Range("A2:AC1048576").ClearContents
           
    ' Очистка листа
    ws10.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws11.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws12.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws13.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws14.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws15.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws16.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws17.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws18.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws19.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws20.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws21.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws22.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws23.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws24.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws25.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws26.Range("A2:AC1048576").ClearContents
   
    ' Очистка листа
    ws27.Range("A2:AC1048576").ClearContents
       
 
    Application.ScreenUpdating = False
   
    While ws.Cells(r, 1) <> ""
        Dim kodPI As String
        kodPI = ws.Cells(r, 2).Text
               
        If kodPI = "0425.000001" Then
           
            ws1.Range("A" & i1 & ":F" & i1) = ws.Range("A" & r & ":F" & r).Value
            i1 = i1 + 1
        End If
       
       
        If kodPI = "0643.000001" Then
           
            ws2.Range("A" & i2 & ":F" & i2) = ws.Range("A" & r & ":F" & r).Value
            i2 = i2 + 1
        End If
             
       
        If kodPI = "0667.000001" Then
           
            ws3.Range("A" & i3 & ":F" & i3) = ws.Range("A" & r & ":F" & r).Value
            i3 = i3 + 1
        End If
       
        If kodPI = "0987.000001" Then
           
            ws4.Range("A" & i4 & ":F" & i4) = ws.Range("A" & r & ":F" & r).Value
            i4 = i4 + 1
        End If
       
        If kodPI = "0991.000001" Then
           
            ws5.Range("A" & i5 & ":F" & i5) = ws.Range("A" & r & ":F" & r).Value
            i5 = i5 + 1
        End If
       
        If kodPI = "1659.000001" Then
           
            ws6.Range("A" & i6 & ":F" & i6) = ws.Range("A" & r & ":F" & r).Value
            i6 = i6 + 1
        End If
       
        If kodPI = "1670.000001" Then
           
            ws7.Range("A" & i7 & ":F" & i7) = ws.Range("A" & r & ":F" & r).Value
            i7 = i7 + 1
        End If
       
        If kodPI = "1896.000001" Then
           
            ws8.Range("A" & i8 & ":F" & i8) = ws.Range("A" & r & ":F" & r).Value
            i8 = i8 + 1
        End If
       
        If kodPI = "2222.000001" Then
           
            ws9.Range("A" & i9 & ":F" & i9) = ws.Range("A" & r & ":F" & r).Value
            i9 = i9 + 1
        End If
       
        If kodPI = "2359.000001" Then
           
            ws10.Range("A" & i10 & ":F" & i10) = ws.Range("A" & r & ":F" & r).Value
            i10 = i10 + 1
        End If
       
        If kodPI = "2374.000001" Then
           
            ws11.Range("A" & i11 & ":F" & i11) = ws.Range("A" & r & ":F" & r).Value
            i11 = i11 + 1
        End If
       
        If kodPI = "2387.000001" Then
           
            ws12.Range("A" & i12 & ":F" & i12) = ws.Range("A" & r & ":F" & r).Value
            i12 = i12 + 1
        End If
       
        If kodPI = "2466.000000" Then
           
            ws13.Range("A" & i13 & ":F" & i13) = ws.Range("A" & r & ":F" & r).Value
            i13 = i13 + 1
        End If
       
        If kodPI = "2488.000001" Then
           
            ws14.Range("A" & i14 & ":F" & i14) = ws.Range("A" & r & ":F" & r).Value
            i14 = i14 + 1
        End If
       
        If kodPI = "2511.000001" Then
           
            ws15.Range("A" & i15 & ":F" & i15) = ws.Range("A" & r & ":F" & r).Value
            i15 = i15 + 1
        End If
       
        If kodPI = "2818.000001" Then
           
            ws16.Range("A" & i16 & ":F" & i16) = ws.Range("A" & r & ":F" & r).Value
            i16 = i16 + 1
        End If
       
        If kodPI = "2961.000001" Then
           
            ws17.Range("A" & i17 & ":F" & i17) = ws.Range("A" & r & ":F" & r).Value
            i17 = i17 + 1
        End If
       
        If kodPI = "2966.000001" Then
           
            ws18.Range("A" & i18 & ":F" & i18) = ws.Range("A" & r & ":F" & r).Value
            i18 = i18 + 1
        End If
       
        If kodPI = "3005.000001" Then
           
            ws19.Range("A" & i19 & ":F" & i19) = ws.Range("A" & r & ":F" & r).Value
            i19 = i19 + 1
        End If
       
       
        If kodPI = "9866.000001" Then
           
            ws20.Range("A" & i20 & ":F" & i20) = ws.Range("A" & r & ":F" & r).Value
            i20 = i20 + 1
        End If
       
        If kodPI = "9871.000001" Then
           
            ws21.Range("A" & i21 & ":F" & i21) = ws.Range("A" & r & ":F" & r).Value
            i21 = i21 + 1
        End If
                 
       
        If kodPI = "A470.000001" Then
           
            ws22.Range("A" & i22 & ":F" & i22) = ws.Range("A" & r & ":F" & r).Value
            i22 = i22 + 1
        End If
       
        If kodPI = "A513.000001" Then
           
            ws23.Range("A" & i23 & ":F" & i23) = ws.Range("A" & r & ":F" & r).Value
            i23 = i23 + 1
        End If
       
        If kodPI = "A586.000001" Then
           
            ws24.Range("A" & i24 & ":F" & i24) = ws.Range("A" & r & ":F" & r).Value
            i24 = i24 + 1
        End If
       
        If kodPI = "A592.000001" Then
           
            ws25.Range("A" & i25 & ":F" & i25) = ws.Range("A" & r & ":F" & r).Value
            i25 = i25 + 1
        End If
       
        If kodPI = "A777.000001" Then
           
            ws26.Range("A" & i26 & ":F" & i26) = ws.Range("A" & r & ":F" & r).Value
            i26 = i26 + 1
        End If
               
               
        If kodPI = "B027.000001" Then
           
            ws27.Range("A" & i27 & ":F" & i27) = ws.Range("A" & r & ":F" & r).Value
            i27 = i27 + 1
        End If
               
       
       
       
        DoEvents
        r = r + 1
    Wend
   
    Application.ScreenUpdating = True
End Sub

[RuSoldatSe]

а сам файл можно и более подробней что нужно сделать? Из какого столбца брать значения?