Собрать воедино информацию из многих книг на основе заголовков


Я написал некоторый код, чтобы собрать воедино информацию из многих книг в определенной папке по сети. Затем она захватывает данные из каждого листа и помещает их в список, который затем используется сводную таблицу для отображения данных. Вытягивать информацию в книге работает, однако, достаточно хорошо находить и добавления данных после того, как он уже вытащил занимает чрезмерное количество времени. Есть 3 подпрограммы, которые у меня есть, что, как представляется, используют чрезмерное количество времени и надеялся, что я могу получить некоторые советы по лучше функций или просто найти лучшие способы, чтобы выполнить это, чтобы уменьшить время выполнения.

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

' ---------------------------------------------- '
' Collect Data
' Search each sheet for the necessary columns
' ---------------------------------------------- '
Sub Collect_Data(intCurrentColumn As Integer)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CellRange As Range
Dim NextRow As Integer

Dim ThisSheet As Worksheet
Set ThisSheet = ThisWorkbook.ActiveSheet

'Search the Current Active Sheet
With ThisSheet

    'LC
    Set CellRange = .Rows(1).Find(What:="LC", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn)
    End If

    'Part Num
    Set CellRange = .Rows(1).Find(What:="Part Num", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 1)
    End If

    'Qty Shipped
    Set CellRange = .Rows(1).Find(What:="*Open Qty", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 2)
    End If

    'Estimated Ship Date
    Set CellRange = .Rows(1).Find(What:="Estimated Ship Date*", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 3)
    End If

End With

End Sub

Добавление данных - этот саб добавляет скопированных данных от сбора данных до конца данных в первые несколько столбцов, чтобы сформировать "список". (Если это может как-то сочетаться в сбор вспомогательных данных, которые, вероятно, помогают, я просто не мог понять, как убедитесь, что он правильно приложил.)

' ---------------------------------------------- '
' Append Data
' Pull each group of columns and append it to the end of the first group.
' ---------------------------------------------- '
Sub Append_Data(intCurrentColumn)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CopyRange As Range
Dim lngLastRow, lngLastPartsA As Long

'Get the last rows in column A and the column we are starting the range from
lngLastPartsA = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow = PartsWs.Cells(Rows.Count, intCurrentColumn).End(xlUp).Row

'Set range to copy
With PartsWs
    Set CopyRange = .Range(.Cells(2, intCurrentColumn), .Cells(lngLastRow, intCurrentColumn + 3))
End With

'Copy range after data already in Column A
CopyRange.Copy (PartsWs.Cells(lngLastPartsA + 1, 1))

End Sub

Наконец у меня есть чистые участки - это суб убирает все лишние столбцы в таблице деталей, а также делает некоторые вычисления дат для упрощения данных для сводной таблицы. Это петли через каждый ряд (около 4к).

' ---------------------------------------------- '
' Clean Parts
' Clean up the Parts sheet, deleting excess columns/rows and doing date calculations for the Pivot Table
' ---------------------------------------------- '
Sub Clean_Parts()

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim intCount As Integer
Dim lngColumnCount, lngLastRow As Long

PartsWs.Activate
lngColumnCount = PartsWs.Cells(1, Columns.Count).End(xlToLeft).Column

'Delete all excess Columns in sheet
PartsWs.Range(Cells(1, 5), Cells(1, lngColumnCount)).EntireColumn.Delete

lngLastRow = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row

PartsWs.Cells(1, 5).Value = "Compiled Dates"

'Loop to check rows
For intCount = 2 To lngLastRow

    'If the Estimated Ship Date is blank, delete the row
    If IsEmpty(PartsWs.Cells(intCount, 4)) Then

        PartsWs.Rows(intCount).EntireRow.Delete
        intCount = intCount - 1
        lngLastRow = lngLastRow - 1
        If lngLastRow <= intCount Then

            Exit For

        End If

    'If Estimated Ship Date contains a valid date value, put the first day of the week 6 weeks later into column 5
    ElseIf IsDate(PartsWs.Cells(intCount, 4)) Then

        PartsWs.Cells(intCount, 5) = DateAdd("d", 1, DateAdd("ww", 6, DateValue(PartsWs.Cells(intCount, 4)) - Weekday(PartsWs.Cells(intCount, 4), vbMonday)))

    End If

Next intCount

End Sub

Я прошу прощения, если это сбивает с толку или не сделали ну, это было некоторое время, так как я что-то закодировано. Каких-либо новых функций или просто какие-либо советы о том, как сделать это быстрее бегать будут с благодарностью. Между этих 3 сабов сейчас это около 4 минут.



124
3
задан 6 апреля 2018 в 05:04 Источник Поделиться
Комментарии
1 ответ

Основные изменения я сделал бы код


  • Добавить Option Explicit в верхней части каждого модуля - первая линия обороны

  • Объявить Сабы как Public или Private - явно


    • Частная субтитры не доступны за пределами их модуль (меньший масштаб)


  • Суб имена не следует использовать подчеркивания, потому что это может мешать событий VBA


    • Workbook_Open(), Worksheet_SelectionChange()и т. д.


  • Определить параметры явно ByVal или ByRef чтобы прояснить намерения


    • ByVal отправляет копии значения (изменения в текущий узел не повлияет на вызов подпрограммы

    • ByRef передает указатель на объект (изменения в текущий узел будет "видно" в звонящего)


  • Определить параметр типы явно (Long, String, Variant, Range, Objectи т. д.)

  • ОП правильно использует ThisWorkbook для работы с файлом, в котором выполняется код

  • Конвертировать все ИНЦ долго, и падение венгерской нотации (не полезно)

  • Соблюдайте отступ, на надлежащем уровне

  • Всегда полные диапазоны. Заявление ниже ошибок, если параметру activesheet не PartsWS

    'Delete all excess Columns in sheet
    PartsWs.Range(Cells(1, 5), Cells(1, lngColumnCount)).EntireColumn.Delete

    Обновление:

    PartsWs.Range(PartsWs.Cells(1,5),PartsWs.Cells(1,lngColumnCount)).EntireColumn.Delete
    .


  • Копия с массивами (только данные), а не буфер обмена и форматирование ячеек (если не требуется)


    • Это самое значительное улучшение в производительности - главный приоритет


  • Преобразован For петля для удаления строк с пустыми датами, чтобы автофильтр


    • Удаление одной строки происходит очень медленно, особенно с большим количеством строк

    • Реализация этого For петли довольно замысловатое

    • Первое правило для упрощения удаления строк с петель перейти от последней строки до


Другие Ноты


  • Работа с ActiveSheet следует всегда избегать


    • Лист активны в данный момент на экране не может быть предназначен один


      • Если пользователь будет вынужден активировать его, и не допускается, чтобы изменить его во время бежит


    • Заменить его призван листа, используя на глобальном код наименование (Sheet1)

    • Кодовые имена не могут быть легко отредактированы пользователями, потому что они доступны только через Редакторе VBA (в верхнем левом углу, в окне проекта Окно), в отличие от вкладки имен, которые можно редактировать, дважды щелкнув на нем, или на вкладке индекс, который изменяется всякий раз, когда порядок изменен пользователем


  • Ниже код не проверял


Option Explicit

Public Sub CollectData(ByVal partCol As Long)
Dim partWs As Worksheet: Set partWs = ThisWorkbook.Sheets(2)
Dim thisWs As Worksheet: Set thisWs = ThisWorkbook.ActiveSheet
Dim lRow As Long, lCol As Long, hdr As Variant, c As Long, lrPart As Long
Dim lc As Long, prt As Long, qty As Long, shp As Long, lch As String, arr As Variant

lRow = thisWs.UsedRange.Rows.Count
lCol = thisWs.Cells(1, Columns.Count).End(xlToLeft)
hdr = thisWs.Range(thisWs.Cells(1, 1), thisWs.Cells(1, lCol))
lrPart = partWs.UsedRange.Rows.Count

For c = 1 To lCol
lch = LCase(hdr(1, c))
Select Case True
Case lch = "lc": lc = c
Case lch = "part num": prt = c
Case InStr(lch, "open qty") > 0: qty = c
Case InStr(lch, "estimated ship date") > 0: shp = c
End Select
Next

'Copy columns (data only, without cell formatting)
partWs.Range(partWs.Cells(2, partCol), partWs.Cells(lrPart, partCol + 3)).Clear

arr = thisWs.Range(thisWs.Cells(1, lc), thisWs.Cells(lRow, lc))
partWs.Range(partWs.Cells(1, partCol + 0), partWs.Cells(lRow, partCol + 0)) = arr
arr = thisWs.Range(thisWs.Cells(1, prt), thisWs.Cells(lRow, prt))
partWs.Range(partWs.Cells(1, partCol + 1), partWs.Cells(lRow, partCol + 1)) = arr
arr = thisWs.Range(thisWs.Cells(1, qty), thisWs.Cells(lRow, qty))
partWs.Range(partWs.Cells(1, partCol + 2), partWs.Cells(lRow, partCol + 2)) = arr
arr = thisWs.Range(thisWs.Cells(1, shp), thisWs.Cells(lRow, shp))
partWs.Range(partWs.Cells(1, partCol + 3), partWs.Cells(lRow, partCol + 3)) = arr
End Sub


Public Sub AppendData(ByVal partCol As Long)
Dim partsWs As Worksheet: Set partsWs = ThisWorkbook.Sheets(2)

Dim lrP, lrA As Long, arr As Variant

lrA = partsWs.Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Column A
lrP = partsWs.Cells(Rows.Count, partCol).End(xlUp).Row 'Last Row in Column partCol

With partsWs 'Copy range after data in Column A (data only, without cell formatting)
arr = .Range(.Cells(2, partCol), .Cells(lrP, partCol + 3))
.Range(.Cells(lrA + 1, 1), .Cells(lrA + 1 + lrP, 4)) = arr
End With
End Sub


Public Sub CleanParts()
Const DT_COL = 4
Dim partsWs As Worksheet: Set partsWs = ThisWorkbook.Sheets(2)
Dim i As Long, lc As Long, lr As Long, oldDt As Date, newDt As Date, arr As Variant

lc = partsWs.Cells(1, Columns.Count).End(xlToLeft).Column
lr = partsWs.Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Column A
partsWs.Range(partsWs.Cells(1, DT_COL + 1), partsWs.Cells(1, lc)).EntireColumn.Delete
'Delete rows with blank Estimated Ship Date - AutoFilter
Application.ScreenUpdating = False: Application.EnableEvents = False
With partsWs.UsedRange.Columns(DT_COL)
.AutoFilter Field:=DT_COL, Criteria1:="<>"
If .Columns(DT_COL).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
.Rows(1).Hidden = True
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Rows(1).Hidden = False
End If
.AutoFilter
End With
Application.ScreenUpdating = True: Application.EnableEvents = True

'If Estimated Ship Date is valid date, put 1st day of week, 6 weeks later in col 5
arr = partsWs.Range(partsWs.Cells(1, DT_COL), partsWs.Cells(lr, DT_COL + 1))
For i = 2 To lr
If Not IsError(arr(i, 1)) Then
If IsDate(arr(i, 1)) Then
oldDt = arr(i, 1)
newDt = DateAdd("ww", 6, DateValue(oldDt) - Weekday(oldDt, vbMonday))
arr(i, 2) = DateAdd("d", 1, newDt)
End If
End If
Next
partsWs.Range(partsWs.Cells(1, DT_COL), partsWs.Cells(lr, DT_COL + 1)) = arr
partsWs.Cells(1, DT_COL + 1).Value = "Compiled Dates"
End Sub


Замечание по поводу файлов из сети

Я постоянно испытывал очень большие задержки при получении данных, открыв файл из сетевой путь (начиная с "\\...")

Решение было сначала скопировать все файлы на локальный путь, открыть их локально и после чтения-только операция, удаление локальной копии (намного быстрее, а также устраняет читал-только предупреждение, что файл может быть заблокирован другим пользователем)

2
ответ дан 7 апреля 2018 в 06:04 Источник Поделиться