Есть такая задачка: по событию на изменение в ячейки подгружать данные. Однако подгружаемые данные (огромный массив) хотелось бы как-то держать в памяти типа глобальной переменной. Чтобы не загружать его постоянно, потому как тормозит процесс. Пробовал через глобальную переменную, но она в модуле листа почему-то не работает.
Вроде разобрался.
Есть такая задачка: по событию на изменение в ячейки подгружать данные. Однако подгружаемые данные (огромный массив) хотелось бы как-то держать в памяти типа глобальной переменной. Чтобы не загружать его постоянно, потому как тормозит процесс. Пробовал через глобальную переменную, но она в модуле листа почему-то не работает.
Я бы предложил ее удалить - так как казалось что это проблема - но оказалось все ок! В модуле листа все стандартно работает, хотя по началу не работало - потому и показалось может есть какие-то ограничения на глобальные переменные в модуле листа Ну а впрочем может кому то пригодится. [vba]
Код
Public arr() As Variant Sub Путь_к_файлу() Dim FilesToOpen Dim OpenPath As String OpenPath = CStr(ThisWorkbook.Path) 'ChDrive "C:\Program Files" 'ChDrive OpenPath 'ChDir OpenPath FilesToOpen = Application.GetOpenFilename _ ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False) If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Файл не выбран!" Exit Sub End If Cells(2, "F") = FilesToOpen End Sub Sub Открытие_файла() Application.ScreenUpdating = False Set importWb = Workbooks.Open(Cells(2, "F")) For Each ws In importWb.Sheets With ws lr = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A2:D" & lr).Copy cr = ThisWorkbook.Sheets("Source").Cells(ThisWorkbook.Sheets("Source").Rows.Count, "A").End(xlUp).Row + 1 ThisWorkbook.Sheets("Source").Range("A" & cr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ThisWorkbook.Sheets("Source").Range("E" & CStr(cr) & ":E" & cr + lr - 1).Value = ws.Name End With Next Application.CutCopyMode = False importWb.Close False With Sheets("Source") arr = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value End With Sheets("Коэффициенты").Select Application.ScreenUpdating = True End Sub
[/vba]
в модуле листа [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Count <> 1 Then Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False If Target.Column = 2 Then tra = Target.Value trp = Target.Offset(, -1).Value For i = 1 To UBound(arr) If trp = arr(i, 5) Then If tra = arr(i, 1) Then Target.Offset(, 1).Value = arr(i, 2) Target.Offset(, 3).Value = arr(i, 3) Target.Offset(, 4).Value = arr(i, 4) End If End If Next End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
Я бы предложил ее удалить - так как казалось что это проблема - но оказалось все ок! В модуле листа все стандартно работает, хотя по началу не работало - потому и показалось может есть какие-то ограничения на глобальные переменные в модуле листа Ну а впрочем может кому то пригодится. [vba]
Код
Public arr() As Variant Sub Путь_к_файлу() Dim FilesToOpen Dim OpenPath As String OpenPath = CStr(ThisWorkbook.Path) 'ChDrive "C:\Program Files" 'ChDrive OpenPath 'ChDir OpenPath FilesToOpen = Application.GetOpenFilename _ ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False) If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Файл не выбран!" Exit Sub End If Cells(2, "F") = FilesToOpen End Sub Sub Открытие_файла() Application.ScreenUpdating = False Set importWb = Workbooks.Open(Cells(2, "F")) For Each ws In importWb.Sheets With ws lr = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A2:D" & lr).Copy cr = ThisWorkbook.Sheets("Source").Cells(ThisWorkbook.Sheets("Source").Rows.Count, "A").End(xlUp).Row + 1 ThisWorkbook.Sheets("Source").Range("A" & cr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ThisWorkbook.Sheets("Source").Range("E" & CStr(cr) & ":E" & cr + lr - 1).Value = ws.Name End With Next Application.CutCopyMode = False importWb.Close False With Sheets("Source") arr = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value End With Sheets("Коэффициенты").Select Application.ScreenUpdating = True End Sub
[/vba]
в модуле листа [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Count <> 1 Then Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False If Target.Column = 2 Then tra = Target.Value trp = Target.Offset(, -1).Value For i = 1 To UBound(arr) If trp = arr(i, 5) Then If tra = arr(i, 1) Then Target.Offset(, 1).Value = arr(i, 2) Target.Offset(, 3).Value = arr(i, 3) Target.Offset(, 4).Value = arr(i, 4) End If End If Next End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub