Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Ответ
 
Опции темы
Старый 11.11.2010, 14:57   #1
ViktorG
Новичок
 
Регистрация: 29.10.2010
Сообщений: 3
Репутация: 10
По умолчанию Оптимизация кода

Так как только начинаю работать с VBA то
прошу помочь оптимизировать данный код:

Sub Proverka()
Dim ss, zz As Range
oWin = Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, "\") + 1)
NewFN = Application.GetOpenFilename(Title:= "Пожалуйста выберите файл")
Workbooks.OpenText Filename:=NewFN
newwn = Mid(NewFN, InStrRev(NewFN, "\") + 1)
Windows(newwn).Activate
Columns("A:V").Select
Selection.Copy
Windows(oWin).Activate
Worksheets.Add
Range("A1").Select
ActiveSheet.Paste
Selection.UnMerge
Worksheets(2).Name = "Их"
Worksheets(1).Name = "Наш"
Worksheets("Наш").Activate

1:
nRow = 1 ' Или Ваше значение
i = 1
Application.ScreenUpdating = False
With ActiveSheet.Range("a1:F1")
Set c = .Find("FM", LookIn:=xlValues)
Set d = .Find("IM", LookIn:=xlValues)
Set e = .Find("OT", LookIn:=xlValues)
If Not c Is Nothing Then
FMAdres = c.Address
FMColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
If Not d Is Nothing Then
IMAdres = d.Address: IMColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
If Not e Is Nothing Then
OTAdres = e.Address: OTColumnName = Mid(c.Address, 2, (InStr(2, c.Address, "$") - 2))
End If
' MsgBox (FMAdres & vbCr & FMColumnName & vbCr & IMAdres & vbCr & OTAdres)
End With

If FMColumnName = "B" Then
For Each ss In ActiveWorkbook.ActiveSheet.UsedRang e.Columns(5).Cells
ss.Value = Replace(ss, "д. ", "")
ss.Value = Replace(ss, "с. ", "")
ss.Value = Replace(ss, "п. ", "")
Next
End If
While ActiveSheet.Cells(nRow, 2) <> ""
If FMColumnName = "B" Then
Range("W" & i).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-21],"" "",RC[-20],"" "",RC[-19],"" "",RC[-18])"
Range("X" & i).Select
Range("X" & i).Value = Range("M" & i).Value
ElseIf FMColumnName = "C" Then
Range("CE" & i).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
Range("CF" & i).Select
ActiveCell.FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"
If i > 1 Then
Range("AD" & i).Select
Range("AD" & i).Value = Range("CF" & i).Value
End If
End If
i = i + 1
nRow = nRow + 1
Wend
Application.ScreenUpdating = True
If ActiveSheet.Name = "Их" Then
Application.ScreenUpdating = 0
Windows(newwn).Activate: Worksheets.Add
Windows(oWin).Activate
nRow = 2: i = 2
Worksheets("наш").Activate
While ActiveSheet.Cells(nRow, 2) <> ""
Range("Y" & i).Select
ActiveCell.FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],Их!RC[58]:R[3595]C[58],1,0)),0,VLOOKUP(RC[-2],Их!RC[58]:R[3595]C[58],1,0))"
i = i + 1: nRow = nRow + 1
Wend
m = 1
For Each zz In ActiveWorkbook.ActiveSheet.UsedRang e.Columns(25).Cells
If zz.Value = 0 Then
Workbooks("едк").Worksheets(1).Rang e("A" & m).Value = "=[" & oWin & "]" & "Наш!R" & m & "C23"
Workbooks("едк").Worksheets(1).Rang e("A" & m).Value = Workbooks("едк").Worksheets(1).Rang e("A" & m).Value
m = m + 1
End If
Next
Application.DisplayAlerts = False
Worksheets("наш").Delete
Application.DisplayAlerts = True
Worksheets("Их").Activate
Range("CE:CF").ClearContents
Windows(newwn).Activate
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.TabRatio = 0.6
' LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
' For r = LastRow To 1 Step -1
' If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
' Next r
Application.ScreenUpdating = True
MsgBox ("Готово")
Exit Sub
End If

Worksheets("Их").Activate
GoTo 1

MsgBox ("Готово")

End Sub

Последний раз редактировалось ViktorG; 11.11.2010 в 15:05.
ViktorG вне форума   Ответить с цитированием
Старый 11.11.2010, 19:38   #2
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,821
Репутация: 1220

skype: ExcelVBA.ru
По умолчанию

оптимизировал кусок кода:
(не полностью - но уже намного лучше, чем было)

Код:

    Application.ScreenUpdating = False
    Dim FMColumn%, IMColumn%, OTColumn%
    On Error Resume Next
    With Range("A1:F1")
        FMColumn% = .Find("FM").Column
        IMColumn% = .Find("IM").Column
        OTColumn% = .Find("OT").Column
    End With

    If FMColumn% = 2 Then
        With ActiveSheet.UsedRange.Columns(5)
            .Replace "д. ", ""
            .Replace "с. ", ""
            .Replace "п. ", ""
        End With
    End If

    While Cells(nRow, 2) <> ""
        Select Case FMColumn%
            Case 2
                Range("W" & i).FormulaR1C1 = "=CONCATENATE(RC[-21],"" "",RC[-20],"" "",RC[-19],"" "",RC[-18])"
                Range("X" & i).Value = Range("M" & i).Value
            Case 3
                Range("CE" & i).FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
                Range("CF" & i).FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"
                If i > 1 Then Range("AD" & i) = Range("CF" & i).Value
        End Select
        i = i + 1: nRow = nRow + 1
    Wend


Последний раз редактировалось EducatedFool; 11.11.2010 в 19:41.
EducatedFool вне форума   Ответить с цитированием
Старый 12.11.2010, 10:57   #3
ViktorG
Новичок
 
Регистрация: 29.10.2010
Сообщений: 3
Репутация: 10
По умолчанию

Case 3
Range("CE" & i).FormulaR1C1 = "=CONCATENATE(RC[-80],"" "",RC[-79],"" "",RC[-78],"" "",RC[-74])"
Range("CF" & i).FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],Наш!R2C23:R1907C24,2,0)),0,VLOOKUP (RC[-1],Наш!R2C23:R1907C24,2,0))"


(Range("CF" & i).FormulaR1C1 =) почему то не работает. Не заполняется формула.
ViktorG вне форума   Ответить с цитированием
Старый 12.11.2010, 13:47   #4
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,821
Репутация: 1220

skype: ExcelVBA.ru
По умолчанию

Цитата:
почему то не работает. Не заполняется формула.
уберите пробел после VLOOKUP
EducatedFool вне форума   Ответить с цитированием
Старый 12.11.2010, 15:43   #5
ViktorG
Новичок
 
Регистрация: 29.10.2010
Сообщений: 3
Репутация: 10
По умолчанию

Большое спасибо
ViktorG вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Оптимизация кода Shouldercannon Общие вопросы Delphi 23 22.07.2010 22:45
Оптимизация кода WoWan-SM Общие вопросы .NET 4 27.04.2010 11:33
Оптимизация кода. Alex Cones Общие вопросы Delphi 19 12.10.2009 20:51
Оптимизация кода viscas PHP 3 31.05.2009 16:04
Оптимизация кода Terran Общие вопросы Delphi 6 01.11.2008 17:57


13:20.


Powered by vBulletin® Version 3.8.8 Beta 2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

RusProfile.ru


Справочник российских юридических лиц и организаций.
Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru