как упростить макрос - Microsoft Office Excel

Obey177 · 18.08.2012, 17:25

ребят как упростить вот такой код

Код:

Public Sub Superflags()
Dim Abo, list1, list2, Zadvandsoobsh As String
Dim Bstart, Bend, Bup, Bend1, Soobsh, IntList1, IntList2, i, FindeMode, FindeMode1, j, g, a, Bstart1, Bend11, Bstart2, Bend2, Bstart3, Bend3, Bstart4, Bend4 As Integer
Dim Bstart5, Bend5, Bstart6, Bend6, Bstart7, Bend7, Bstart8, Bend8, Bstart9, Bend9, Bstart10, Bend10, Bstart12, Bend12, Bstart13, Bend13, Bstart14, Bend14, Bstart15, Bend15, Bstart16, Bend16, Bstart17, Bend17 As Integer
Dim FindeMode2, FindeMode3, FindeMode4, FindeMode5, FindeMode6, FindeMode7, FindeMode8, FindeMode9, FindeMode10, FindeMode11, FindeMode12, FindeMode13, FindeMode14, FindeMode15 As Integer
Dim b, c, h, q, w, e, r, t, y, u, f, x, m, n As Integer
Dim NameZadvB As Object
Dim ZadvandsoobshB As Object
list1 = "Ëèñò1"
list2 = "Ëèñò2"
Bstart = Sheets(list1).Range("D2").Cells.Column
Bend = Sheets(list1).Range("AP2").Cells.Column
Bstart1 = Sheets(list1).Range("D3").Cells.Column
Bend11 = Sheets(list1).Range("U3").Cells.Column
Bstart2 = Sheets(list1).Range("D4").Cells.Column
Bend2 = Sheets(list1).Range("AA4").Cells.Column
Bstart3 = Sheets(list1).Range("D5").Cells.Column
Bend3 = Sheets(list1).Range("N5").Cells.Column
Bstart4 = Sheets(list1).Range("D6").Cells.Column
Bend4 = Sheets(list1).Range("AJ6").Cells.Column
Bstart5 = Sheets(list1).Range("D7").Cells.Column
Bend5 = Sheets(list1).Range("O7").Cells.Column
Bstart6 = Sheets(list1).Range("D8").Cells.Column
Bend6 = Sheets(list1).Range("AH8").Cells.Column
Bstart7 = Sheets(list1).Range("D9").Cells.Column
Bend7 = Sheets(list1).Range("U9").Cells.Column
Bstart8 = Sheets(list1).Range("D10").Cells.Column
Bend8 = Sheets(list1).Range("AF10").Cells.Column
Bstart9 = Sheets(list1).Range("D11").Cells.Column
Bend9 = Sheets(list1).Range("K11").Cells.Column
Bstart10 = Sheets(list1).Range("D12").Cells.Column
Bend10 = Sheets(list1).Range("V12").Cells.Column
Bstart12 = Sheets(list1).Range("D13").Cells.Column
Bend12 = Sheets(list1).Range("J13").Cells.Column
Bstart13 = Sheets(list1).Range("D14").Cells.Column
Bend13 = Sheets(list1).Range("BG14").Cells.Column
Bstart14 = Sheets(list1).Range("D15").Cells.Column
Bend14 = Sheets(list1).Range("AG15").Cells.Column
Bstart15 = Sheets(list1).Range("D16").Cells.Column
Bend15 = Sheets(list1).Range("AW16").Cells.Column
Bstart16 = Sheets(list1).Range("D17").Cells.Column
Bend16 = Sheets(list1).Range("N17").Cells.Column



Bend1 = Worksheets(list1).Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To Bend1
g = 2
    Set ZadvandsoobshB = Worksheets(list1).Cells(i, 2)
    FindeMode = InStr(1, ZadvandsoobshB.Value, "Osn")
    FindeMode1 = InStr(1, ZadvandsoobshB.Value, "Asn")
    FindeMode2 = InStr(1, ZadvandsoobshB.Value, "Bsn")
    FindeMode3 = InStr(1, ZadvandsoobshB.Value, "Esn")
    FindeMode4 = InStr(1, ZadvandsoobshB.Value, "Hsn")
    FindeMode5 = InStr(1, ZadvandsoobshB.Value, "Msn")
    FindeMode6 = InStr(1, ZadvandsoobshB.Value, "Psn")
    FindeMode7 = InStr(1, ZadvandsoobshB.Value, "Ksn")
    FindeMode8 = InStr(1, ZadvandsoobshB.Value, "Usn")
    FindeMode9 = InStr(1, ZadvandsoobshB.Value, "Qsn")
    FindeMode10 = InStr(1, ZadvandsoobshB.Value, "Wsn")
    FindeMode11 = InStr(1, ZadvandsoobshB.Value, "Tsn")
    FindeMode12 = InStr(1, ZadvandsoobshB.Value, "Ysn")
    FindeMode13 = InStr(1, ZadvandsoobshB.Value, "Isn")
    FindeMode14 = InStr(1, ZadvandsoobshB.Value, "Fsn")
    FindeMode15 = InStr(1, ZadvandsoobshB.Value, "Gsn")

If FindeMode <> 0 Then
        For j = Bstart To Bend
            Set NameZadvB = Worksheets(list1).Cells(i, j)
            Abo = Replace(ZadvandsoobshB, "Osn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
      g = g + 1
        Next
        ElseIf FindeMode1 <> 0 Then
        For a = Bstart1 To Bend11
            Set NameZadvB = Worksheets(list1).Cells(i, a)
            Abo = Replace(ZadvandsoobshB, "Asn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode2 <> 0 Then
        For b = Bstart2 To Bend2
            Set NameZadvB = Worksheets(list1).Cells(i, b)
            Abo = Replace(ZadvandsoobshB, "Bsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next

Obey177 · 18.08.2012, 17:25

Код:

 ElseIf FindeMode3 <> 0 Then
        For c = Bstart3 To Bend3
            Set NameZadvB = Worksheets(list1).Cells(i, c)
            Abo = Replace(ZadvandsoobshB, "Esn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode4 <> 0 Then
        For h = Bstart4 To Bend4
            Set NameZadvB = Worksheets(list1).Cells(i, h)
            Abo = Replace(ZadvandsoobshB, "Hsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode5 <> 0 Then
        For q = Bstart5 To Bend5
            Set NameZadvB = Worksheets(list1).Cells(i, q)
            Abo = Replace(ZadvandsoobshB, "Msn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
      g = g + 1
        Next
        ElseIf FindeMode6 <> 0 Then
        For w = Bstart6 To Bend6
            Set NameZadvB = Worksheets(list1).Cells(i, w)
            Abo = Replace(ZadvandsoobshB, "Psn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode7 <> 0 Then
        For e = Bstart7 To Bend7
            Set NameZadvB = Worksheets(list1).Cells(i, e)
            Abo = Replace(ZadvandsoobshB, "Ksn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode8 <> 0 Then
        For r = Bstart8 To Bend8
            Set NameZadvB = Worksheets(list1).Cells(i, r)
            Abo = Replace(ZadvandsoobshB, "Usn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode9 <> 0 Then
        For t = Bstart9 To Bend9
            Set NameZadvB = Worksheets(list1).Cells(i, t)
            Abo = Replace(ZadvandsoobshB, "Qsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
                ElseIf FindeMode10 <> 0 Then
        For y = Bstart10 To Bend10
            Set NameZadvB = Worksheets(list1).Cells(i, y)
            Abo = Replace(ZadvandsoobshB, "Wsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode11 <> 0 Then
        For u = Bstart12 To Bend12
            Set NameZadvB = Worksheets(list1).Cells(i, u)
            Abo = Replace(ZadvandsoobshB, "Tsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode12 <> 0 Then
        For f = Bstart13 To Bend13
            Set NameZadvB = Worksheets(list1).Cells(i, f)
            Abo = Replace(ZadvandsoobshB, "Ysn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode13 <> 0 Then
        For x = Bstart14 To Bend14
            Set NameZadvB = Worksheets(list1).Cells(i, x)
            Abo = Replace(ZadvandsoobshB, "Isn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
                ElseIf FindeMode14 <> 0 Then
        For m = Bstart15 To Bend15
            Set NameZadvB = Worksheets(list1).Cells(i, m)
            Abo = Replace(ZadvandsoobshB, "Fsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
        ElseIf FindeMode15 <> 0 Then
        For n = Bstart16 To Bend16
            Set NameZadvB = Worksheets(list1).Cells(i, n)
            Abo = Replace(ZadvandsoobshB, "Gsn", NameZadvB)
            Worksheets(list2).Cells(i, g).Value = Abo
            g = g + 1
        Next
    End If
     Next
     
     
    

End Sub

IgorGO · 18.08.2012, 18:24

полагаю, многим оказалась просто непосильной глубина мысли заложенная в Вашем коде.
а Вы можете рассказать "на пальцах", как для простых, а лучше - на небольшом примере, чего Вы хотите добиться в итоге.

nilem · 18.08.2012, 19:24

попробую угадать

Код:

Sub Superflags2()
Dim i As Long, j As Long, u As Long, g As Long, s As String, t As String
Dim FindeMode

FindeMode = Array("Osn", "Asn", "Bsn", "Esn", "Hsn", "Msn", "Psn", "Ksn", _
                  "Usn", "Qsn", "Wsn", "Tsn", "Ysn", "Isn", "Fsn", "Gsn")

With Sheets("Лист1")
    For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        g = 2: s = .Cells(i, 2)
        For j = 4 To .Cells(i, Columns.Count).End(xlToLeft).Column
            t = .Cells(i, j).Value
            For u = 0 To UBound(FindeMode)
                If InStr(s, FindeMode(u)) Then Sheets("Лист2").Cells(i, g).Value = Replace(s, FindeMode(u), t)
            Next u
            g = g + 1
        Next
    Next
End With

End Sub

Obey177 · 20.08.2012, 19:01

Цитата:

Сообщение от nilem

попробую угадать

Код:

Sub Superflags2()
Dim i As Long, j As Long, u As Long, g As Long, s As String, t As String
Dim FindeMode

FindeMode = Array("Osn", "Asn", "Bsn", "Esn", "Hsn", "Msn", "Psn", "Ksn", _
                  "Usn", "Qsn", "Wsn", "Tsn", "Ysn", "Isn", "Fsn", "Gsn")

With Sheets("Лист1")
    For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        g = 2: s = .Cells(i, 2)
        For j = 4 To .Cells(i, Columns.Count).End(xlToLeft).Column
            t = .Cells(i, j).Value
            For u = 0 To UBound(FindeMode)
                If InStr(s, FindeMode(u)) Then Sheets("Лист2").Cells(i, g).Value = Replace(s, FindeMode(u), t)
            Next u
            g = g + 1
        Next
    Next
End With

End Sub

Спасибо очень помогли

18.08.2012, 18:24	#3
IgorGO Новичок СтарожилДжуниор Регистрация: 05.02.2008 Сообщений: 9,487	полагаю, многим оказалась просто непосильной глубина мысли заложенная в Вашем коде. а Вы можете рассказать "на пальцах", как для простых, а лучше - на небольшом примере, чего Вы хотите добиться в итоге. Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Можно упростить этот макрос?	valerij	Microsoft Office Excel	84	14.09.2014 16:17
Возможно ли упростить макрос?	KOSTIK1	Microsoft Office Excel	6	31.08.2011 14:01
как возможно упростить?	monogramm	Общие вопросы по Java, Java SE, Kotlin	3	01.06.2011 01:40
Упростить макрос	valerij	Microsoft Office Excel	8	20.01.2011 12:10
помогите упростить простой макрос	frantic150	Microsoft Office Excel	2	23.06.2009 04:55