#arrays #excel #vba #performance #loops
#массивы #excel #vba #Производительность #циклы
Вопрос:
Я обращаюсь за советом в отношении повышения производительности для большого набора данных (примерно 175 тыс. строк на каждом листе и 39 столбцов A: AM (сравнение листа 1 и листа 2). Эти листы экспортируются из access, а мой VBA записывается в Access. У меня есть кодирование, в котором используется цикл «для», который проверяет ячейку за ячейкой и подчеркивает, есть ли несоответствие в каждой относительной ячейке.
Мой вопрос — ускорит ли использование функции массива или словаря процесс? Если да, можете ли вы предоставить хлебные крошки, чтобы пролить свет на то, как выполнить? В настоящее время выполнение этого кода занимает около 3 часов. Примерно 2 минуты на экспорт из Access в Excel, а остальное время представляет собой цикл и выделение.
В качестве примечания — я написал код для условного форматирования, и он работает невероятно быстро. Основная проблема заключается в том, что я не могу скопировать / вставить листы с выделенными ячейками в новые листы, оставив условия позади. Мне было бы интересно услышать, нашел ли кто-нибудь способ маневрировать этим минным полем.
Код ниже:
DoCmd.SetWarnings False
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlSheet, xlSheetPre, xlSheetPost As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim iSheet As Long, iRow As Long, iCol As Long, cols As Long
Dim MaxLastRow As Long, MaxLastCol As Long
Dim LastRow1 As Range, LastRow2 As Range
Dim LastCol1 As Range, LastCol2 As Range
Dim i As Integer
SQL = "SELECT * From Pre"
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
Set xlapp = Excel.Application
xlapp.Visible = True
Set xlbook = xlapp.Workbooks.Add
i = 1
Do
Set xlSheet = Sheets.Add(after:=Sheets(Sheets.Count))
i = i 1
Loop Until i = 2 ' the number 2 represents how many sheets you want to add to the
workbook
Set xlSheet = xlbook.Worksheets(1) ' Finds worksheet (1) and begins loading data from SQL
table above
With xlSheet
.Name = "Pre" ' Name the worksheet
.Range("a1:am1").Font.Bold = True 'Converts headers in row 1 to
bold font
.Range("A2").CopyFromRecordset rs1 'Copies all data from selected
table (SQL)into your worksheet
.Range("a1").AutoFilter ' Adds filter to your columns
.Cells.Columns.AutoFit ' Adjust worksheet column width to autofit
your data
.Range("a1:am1").Interior.ColorIndex = 37 ' Changes color of cell
' This loop reads all headers in your access table and places
them on worksheet
For cols = 0 To rs1.Fields.Count - 1
.Cells(1, cols 1).Value = rs1.Fields(cols).Name
Next
End With
SQL = "SELECT * From Post"
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
Set xlSheet = xlbook.Worksheets(2)
With xlSheet
.Name = "Post" ' Name the worksheet
.Range("a1:am1").Font.Bold = True 'Converts headers in row 1 to
bold font
.Range("A2").CopyFromRecordset rs1 'Copies all data from selected
table (SQL)into your worksheet
.Range("a1").AutoFilter ' Adds filter to your columns
.Cells.Columns.AutoFit ' Adjust worksheet column width to autofit
your data
.Range("a1:am1").Interior.ColorIndex = 37 ' Changes color of cell
' This loop reads all headers in your access table and places
them on worksheet
' This loop reads all headers in your access table and places them on worksheet
For cols = 0 To rs1.Fields.Count - 1
.Cells(1, cols 1).Value = rs1.Fields(cols).Name
Next
End With
Set xlSheetPre = xlbook.Worksheets(1)
Set xlSheetPost = xlbook.Worksheets(2)
Set LastRow1 = xlSheetPre.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set LastRow2 = xlSheetPost.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not LastRow1 Is Nothing Then
If Not LastRow2 Is Nothing Then
If LastRow1.Row > LastRow2.Row Then
MaxLastRow = LastRow1.Row
Else
MaxLastRow = LastRow2.Row
End If
Else
MaxLastRow = LastRow1.Row
End If
Else
MaxLastRow = LastRow2.Row
End If
Set LastCol1 = xlSheetPre.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set LastCol2 = xlSheetPost.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
If Not LastCol1 Is Nothing Then
If Not LastCol2 Is Nothing Then
If LastCol1.Column > LastCol2.Column Then
MaxLastCol = LastCol1.Column
Else
MaxLastCol = LastCol2.Column
End If
Else
MaxLastCol = LastCol1.Column
End If
Else
MaxLastCol = LastCol2.Column
End If
For iRow = 2 To MaxLastRow 'starting loop on row 2
For iCol = 4 To MaxLastCol 'starting loop on column 4
If xlSheetPre.Cells(iRow, iCol).Value <> xlSheetPost.Cells(iRow, iCol).Value Then
xlSheetPre.Cells(iRow, iCol).Interior.ColorIndex = 4
xlSheetPost.Cells(iRow, iCol).Interior.ColorIndex = 4
End If
Next iCol
Next iRow
SubExit:
On Error Resume Next
rs1.Close
Set rs1 = Nothing
DoCmd.SetWarnings True
Exit Sub
Комментарии:
1. Ваш код помещает заголовки только в листы Excel? Где данные? Ваш код будет выполняться намного быстрее, если вы загружаете данные в массивы и сравниваете массивы: доступ к данным по ячейкам относительно медленный.
2. Также неясно, как
LastRow1может быть etcNothing— вы уже написали заголовки на листе, так что этого никогда не должно произойти.3. Спасибо, что назвали это. Я пропустил свои строки форматирования и, похоже, изначально удалил слишком много. С помощью LastRow1 / 2 я подумал, что если LastRow1 отличается от LastRow2, отрегулируйте лист, у которого меньше, чтобы все сравнения были 1 к 1 между листами.
4. Имеют ли таблицы pre и post общий первичный ключ?
5. Да, столбец A имеет ключ, который выравнивается (a1 на pre = a1 на post) в Access перед экспортом в Excel. Если у Pre есть ключ, которого нет у post, тогда будет выделен ключ Pre.
Ответ №1:
Попробуйте уменьшить количество записей, которые вам нужно сравнить, извлекая только те, которые имеют различия. Есть несколько способов, которыми вы могли бы сделать это в SQL, но в качестве доказательства концепции это сравнивает каждый столбец по очереди, создавая временную таблицу ключей, которая используется для фильтрации извлеченных записей.
Option Compare Database
Option Explicit
Sub DumpToExcel()
Dim n As Integer, SQL As String, fname
' field names
fname = Array("", "F1", "F2", "F3", "F4", "F5", _
"F6", "F7", "F8", "F9", "F10")
' identify diff records
Debug.Print UBound(fname)
DoCmd.SetWarnings False
For n = 1 To UBound(fname)
If n = 1 Then ' create table
SQL = " SELECT post.ID, """ amp; n amp; """ AS Col INTO tmp"
Else
SQL = " INSERT INTO tmp" amp; _
" SELECT post.ID, """ amp; n amp; """ AS Col"
End If
SQL = SQL amp; _
" FROM Post LEFT JOIN pre ON Post.id = pre.id" amp; _
" WHERE NZ([pre].[" amp; fname(n) amp; "],"")<>NZ([post].[" amp; fname(n) amp; "],"");"
DoCmd.RunSQL SQL
Next
DoCmd.SetWarnings True
' extract data
Dim rs1 As DAO.Recordset
SQL = " SELECT * FROM pre" amp; _
" WHERE (((pre.[ID]) In " amp; _
" (SELECT DISTINCT(ID) FROM tmp )));"
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
' create excel
Dim xlapp As Excel.Application, xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlapp = Excel.Application
xlapp.Visible = True
Set xlBook = xlapp.Workbooks.Add
'add sheets as required
Do While xlBook.Sheets.Count < 2
xlBook.Sheets.Add
Loop
' copy recordset to sheet
xlBook.Sheets(1).Range("A2").CopyFromRecordset rs1
MsgBox "Done"
End Sub
Комментарии:
1. Спасибо. Я быстро скопировал кодировку, но получаю всплывающие окна с сообщением «Введите значение параметра -«. ИДЕНТИФИКАТОР», за которым следует «pre.id «. Я рассмотрю этот код, чтобы увидеть, смогу ли я понять это, и дам вам знать.
2. @Erik Измените идентификатор на любое ваше поле первичного ключа
Ответ №2:
«Мой вопрос — ускорит ли использование функции массива или словаря процесс?»
Исходя из опыта, ответ: нет, этого не будет. Причина в том, что вам придется читать ячейки на листе, чтобы в первую очередь заполнить массив или словарь, поэтому… На самом деле это цикл, и вам нужно организовать данные (обычно путем правильной сортировки списков, таблиц, диапазонов и т. Д.), Чтобы свести к минимуму поиск совпадающих записей (строк), чтобы ваши циклы выполнялись быстрее.
Если у вас есть Access, вы можете сделать это напрямую с наборами записей, при условии, что сетевая безопасность вашей компании не мешает перемещению внутри объектов набора записей (мой действительно мешает, и при этом очень сильно — Tanium — настоящая угроза!)
Комментарии:
1. Исходя из моего опыта — если бы вы выполняли вложенный цикл для сравнения записей — использование словаря было бы намного быстрее. Это правда, что загрузка словаря сопряжена с некоторыми накладными расходами, но избежать вложенного цикла того стоит.
2. @TimWilliams: Как вы храните записи с несколькими полями с несколькими типами данных в словаре?
3. Есть ли какое-либо преимущество в использовании словаря против массива?
4. @Erik_U — они разные, это зависит от того, что вам нужно и каковы данные; погуглите оба и убедитесь сами, пожалуйста.
5. Вы можете сохранить любой тип данных в значении словарной записи, но при использовании в этом сценарии «избежать вложенного цикла» обычно это просто индекс строки, указывающий на номер строки в массиве
Ответ №3:
Вот сравнение на основе массива.
Скомпилировано, но не протестировано:
Sub Tester()
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlSheet, wsPre As Excel.Worksheet, wsPost As Excel.Worksheet
Dim rowsPost As Long, rowsPre As Long, rowsMax As Long
Dim colsPre As Long, colsPost As Long, colsMax As Long, flag As Boolean
Dim r As Long, c As Long, rngPre As Range, rngPost As Range, arrPre, arrPost
DoCmd.SetWarnings False
Set xlapp = New Excel.Application 'forgot "New" here?
xlapp.Visible = True
Set xlbook = xlapp.Workbooks.Add()
Do While xlbook.Worksheets.Count < 2 'how many sheets you need in the Workbook
xlbook.Sheets.Add
Loop
Set wsPre = xlbook.Worksheets(1)
Set wsPost = xlbook.Worksheets(2)
PutInWorksheet "SELECT * From Pre", wsPre, "Pre"
PutInWorksheet "SELECT * From Post", wsPost, "Post"
Set rngPre = wsPre.Range("A1").CurrentRegion 'data ranges
Set rngPost = wsPost.Range("A1").CurrentRegion
arrPre = rngPre.Value 'read data to arrays
arrPost = rngPost.Value
rowsPre = UBound(arrPre, 1) 'compare array bounds...
rowsPost = UBound(arrPost, 1)
rowsMax = xlapp.Max(rowsPre, rowsPost)
colsPre = UBound(arrPre, 2)
colsPost = UBound(arrPost, 2)
colsMax = xlapp.Max(colsPre, colsPost)
For r = 2 To rowsMax
flag = (r > rowsPre) Or (r > rowsPost) 'flag whole row if have run out of data in one set...
If flag Then
FlagRanges rngPre.Cells(r, 1).Resize(1, colsMax), _
rngPost.Cells(r, 1).Resize(1, colsMax)
Else
'have two rows to compare
For c = 1 To colsMax
flag = (c > colsPre) Or (c > colsPost) 'run out of cols in one dataset?
If Not flag Then
flag = arrPre(r, c) <> arrPost(r, c) 'compare data
End If
If flag Then
'no data to compare, or data does not match
FlagRanges rngPre.Cells(r, c), rngPost.Cells(r, c)
End If
Next c
End If
Next r
End Sub
Sub FlagRanges(rng1 As Excel.Range, rng2 As Excel.Range)
Const CLR_INDX = 4
rng1.Interior.ColorIndex = CLR_INDX
rng2.Interior.ColorIndex = CLR_INDX
End Sub
'run a query and put the results on a worksheet starting at A1
Sub PutInWorksheet(SQL As String, ws As Excel.Worksheet, _
Optional newName As String = "")
Dim f, c As Excel.Range, rs As dao.Recordset
If Len(newName) > 0 Then ws.Name = newName
Set rs = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
Set c = ws.Range("A1")
For Each f In rs.Fields
c.Value = f.Name
c.Font.Bold = True
Next f
ws.Range("A2").CopyFromRecordset rs
rs.Close
End Sub
Комментарии:
1. Спасибо, Тим. Один вопрос, когда я компилирую, я получаю сообщение об ошибке компиляции: «метод или элемент данных не найден». для «rowsMax = Application.Max (rowsPre, rowsPost)». Это проблема с инструментом> ссылкой?
2. чтобы быть более конкретным, .Max принимает ошибку.
3. Извините, я писал в Excel, поэтому вам понадобится xlapp.Max
4. Отлично, xlApp.Max исправлена ошибка компиляции. Похоже, я столкнулся с еще одной проблемой во вложенной рабочей таблице: «Для каждого f в rs1.fields» указывается, что требуется объект.
5. Для каждого f в rs.fields