Откройте Excel, собирать информацию, хранить ее локально и закройте Excel


Я закончил первую часть моего кода, который запускается из PowerPoint. Шаги, которые он принимает, являются:

  1. Откройте файл Excel, указанной
  2. Выбрать необходимую вкладку с существующей PivotTable
  3. Определения размера набора данных и хранить в colNumb и rowNumb
  4. Копия каждой ячейки в массив IQRngRef и каждой ячейки в верхней строке в IQRef
  5. На столбце a, определить номера строк (scoreBound/whyBound) и значения между строк, содержащих слова "результат" и "почему?" (roleArray)
  6. Вернуть все эти данные в главной подгруппе, так что он может быть сохранен локально и используется в PowerPoint и закройте Excel, прежде чем делать так.

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

Одной четкой корректировки я думаю, что мне придется решать это позднее связывание. Я еще не научился работать с поздним связыванием окончательно, поэтому я добавляю эту часть. Насколько я понимаю, все, что мне нужно сделать, это создать объект Excel и повторно определяют соответственно все мои переменные. Но я также понимаю, что некоторые из функций, которые я использовал в этом коде не может быть доступна без полной загрузки всей библиотеки Excel, и этого я боюсь. Любая помощь будет высоко ценится.

Еще один вопрос у меня есть, если это ОК, чтобы пройти мимо, как многие переменные через различные подгруппы, как видно здесь:

CaptureExcelReferences xlWB, xlApp, pivotSheetName, IQRef, IQRngRef, roleArray, scoreBound, whyBound

Option Explicit
    Public Sub createTableArray()
        '-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
        '~Input file path here in between the quotation marks
        Dim testFilePath As String
        testFilePath = "C:\file.xlsx"

        '~Input name of Sheet with Pivot Tables here in between the quotation marks
        Dim pivotSheetName As String
        pivotSheetName = "IQ_Pivot"
        '-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

        'Timer start
        Dim StartTime As Double
        StartTime = Timer

        Excel.Application.ScreenUpdating = False
        Excel.Application.EnableEvents = False
        Excel.Application.DisplayAlerts = False

        Dim xlApp As Excel.Application
        Set xlApp = New Excel.Application
        'xlApp.Visible = True 'Make Excel visible
        Dim xlWB As Excel.Workbook
        On Error GoTo fileRetrieveError
        Set xlWB = xlApp.Workbooks.Open(testFilePath, True, False, , , , True, Notify:=False)
        If xlWB Is Nothing Then
fileRetrieveError:
            MsgBox ("Error")
            Exit Sub
        End If

        Dim IQRef() As Variant
        Dim IQRngRef() As Variant
        Dim roleArray As Variant
        Dim scoreBound As Long
        Dim whyBound As Long
        CaptureExcelReferences xlWB, xlApp, pivotSheetName, IQRef, IQRngRef, roleArray, scoreBound, whyBound

        xlApp.Application.ScreenUpdating = True
        xlApp.Application.EnableEvents = True
        xlApp.DisplayAlerts = True

        xlWB.Saved = True
        xlWB.Close
        Set xlWB = Nothing
        xlApp.Quit
        Set xlApp = Nothing

        'End Timer
        Dim SecondsElapsed As Double
        SecondsElapsed = Round(Timer - StartTime, 2)
        MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
    End Sub

    Private Sub CaptureExcelReferences(ByVal xlWB As Workbook, ByVal xlApp As Excel.Application, ByVal pivotSheetName As String, ByRef IQRef() As Variant, ByRef IQRngRef() As Variant, ByRef roleArray As Variant, ByRef scoreBound As Long, ByRef whyBound As Long)
        Dim ShRef As Excel.Worksheet
        Set ShRef = xlWB.Worksheets(pivotSheetName)
        Dim colNumb As Long
        colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
        ReDim IQRef(colNumb)
        ReDim IQRngRef(colNumb)
        Dim rowNumb As Long
        rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
        CaptureIQRefsLocally ShRef, xlApp, rowNumb, colNumb, IQRef, IQRngRef
        IdentifyRolesAndScoresRows IQRngRef, rowNumb, roleArray, scoreBound, whyBound
    End Sub

    Private Sub CaptureIQRefsLocally(ByVal ShRef As Worksheet, ByVal xlApp As Excel.Application, ByVal rowNumb As Long, ByVal colNumb As Long, ByRef IQRef As Variant, ByRef IQRngRef As Variant)
        'capture IQ references in arrays. Values for column titles in IQRef and full column Ranges in IQRngRef.
        Dim iCol As Long
        Dim alignIQNumbToArrayNumb
        For iCol = 1 To colNumb
            alignIQNumbToArrayNumb = iCol - 1
            IQRngRef(alignIQNumbToArrayNumb) = xlApp.Transpose(ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value)
            IQRef(alignIQNumbToArrayNumb) = ShRef.Cells(1, iCol).Value
        Next iCol
    End Sub

    Private Sub IdentifyRolesAndScoresRows(ByRef IQRngRef As Variant, ByVal rowNumb As Long, ByRef roleArray As Variant, ByRef scoreBound As Long, ByRef whyBound As Long)
        'Figure out what rows in the array contain the information needed.
        scoreBound = Excel.Application.Match("Score", IQRngRef(0), 0) + 1
        whyBound = Excel.Application.Match("Why?", IQRngRef(0), 0) - 1
        roleArray = Excel.Application.Index(IQRngRef(0), Evaluate("ROW(" & scoreBound & ":" & whyBound & ")"))
    End Sub


202
1
задан 5 марта 2018 в 03:03 Источник Поделиться
Комментарии
2 ответа

Во-первых, вы правы, это не будет работать без соответствующих ссылок включен, но это позже.


Комментарии

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


Переменные

Есть стандартные соглашения об именах в VBA есть camelCase для локальных переменных и PascalCase для других переменных и имена. Вы также хотите давать переменным осмысленные имена.


Dim StartTime As Double
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim IQRef() As Variant
Dim IQRngRef() As Variant
Dim roleArray As Variant
Dim scoreBound As Long
Dim whyBound As Long
Dim ShRef As Excel.Worksheet
Dim colNumb As Long
Dim rowNumb As Long
Dim iCol As Long
Dim alignIQNumbToArrayNumb
ByVal xlWB As Workbook, ByVal xlApp As Excel.Application, ByVal
pivotSheetName As String, ByRef IQRef() As Variant, ByRef IQRngRef()
As Variant, ByRef roleArray As Variant, ByRef scoreBound As Long,
ByRef whyBound As Long)
ByVal ShRef As Worksheet, ByVal xlApp As Excel.Application, ByVal rowNumb
As Long, ByVal colNumb As Long, ByRef IQRef As Variant, ByRef
IQRngRef As Variant)
ByRef IQRngRef As Variant, ByVal rowNumb As Long, ByRef roleArray As
Variant, ByRef scoreBound As Long, ByRef whyBound As Long)


  • Что я могу сказать о whyBound С именем? Не много.

  • Я не уверен, что IQ есть, но мы можем, вероятно, пусть один слайд на формат, из-за чего это может быть. Но, что такое IQRef или IQRngRef (оба варианта)?

  • colNumb и rowNumb лучше бы с двумя дополнительными буквами, которыми можно пользоваться бесплатно! colNumber или даже еще лучше columnNumber или columnIndex.

  • iCol вы перебора что-то? Звучит как targetColumn или columnIndex

  • Вы получаете идею, ShRef это targetSheet да?

Dim alignIQNumbToArrayNumb ты не дал этого типа. Почему нет?


    Dim testFilePath As String
testFilePath = "C:\file.xlsx"
Dim pivotSheetName As String
pivotSheetName = "IQ_Pivot"

Они выглядят как они могли бы быть константами

 Const FILE_PATH as String = "C:\file.xlsx"
Const PIVOT_SHEET_NAME as String = "IQ_Pivot"

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


Как byref

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

Также, пройдя так много аргументов ByRef заставляет меня думать, что вы должны использовать некоторые Functions вместо Subs.

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


Функции листа

Почему -


xlApp.Transpose(
Excel.Application.Match(
Excel.Application.Index(

Вы хотите избежать, используя объектную модель Excel, так зачем полагаться на функции Excel? Кроме того, вы были немного противоречит, используя xlApp и Excel.Application. Если у вас есть xlAppиспользуйте его все время.

Кроме того, Evaluate?


Excel.Application.Index(IQRngRef(0), Evaluate("ROW(" & scoreBound & ":" & whyBound & ")"))

Там должен быть лучший способ?


Магия Чисел

Я вижу вы использовали 1 куча с колоннами. Могли бы также принять, что глобальной константы

Const FIRST_COLUMN as Long = 1

У вас также есть некоторые 0С


IQRngRef(0), 0)


Захватить Некоторые Данные

Вы говорите, что вам нужно, чтобы захватить некоторые данные из Excel, чтобы захватить некоторые данные. Все сразу.

Что-то вроде

    Dim targetLastRow As Long
Dim targetLastColumn As Long
targetLastRow = targetsheet.Cells(Rows.Count, 1).End(xlUp).Row
targetLastColumn = targetsheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim myDataFromExcel As Variant
myDataFromExcel = targetsheet.Range(Cells(1, 1), Cells(targetLastRow, targetLastColumn))

БАМ теперь закройте Excel и у вас есть ваши данные в PowerPoint. Сэкономить много хлопот, верно? И мы будем использовать позднее связывание

    Dim excelApplication As Object
Set excelApplication = CreateObject("Excel.Application")
Dim arrayOfData As Variant
arrayOfData = GetData(excelApplication)
excelApplication.DisplayAlerts = False
excelApplication.Quit

Private Function GetData(ByVal excelApp As Object) As Variant
Dim targetBook As Object
Set targetBook = excelApp.Workbooks.Open(FILE_PATH)
Dim targetSheet As Object
Set targetSheet = targetBook.Sheets(PIVOT_SHEET_NAME)
Dim targetLastRow As Long
Dim targetLastColumn As Long
targetLastRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row
targetLastColumn = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
GetData = targetSheet.Range(Cells(1, 1), Cells(targetLastRow, targetLastColumn))
End Function

Теперь мы имеем все данные из Excel и в PowerPoint, мы уже закрылись Excel и мы можем делать что угодно с данными, в powerpoinit.

Честно, я даже не знаю, почему я прошел excelApplication функции, вы могли бы также просто создать объект и там и там закрыть объект. Особенно поскольку у вас есть те глобальные константы, верно?


Работая с вашими данными

Теперь вы можете создать столько массивов от вашего выбора, как вы хотите, или вы можете делать все, что единый массив.

Dim scoreArray As Variant
scoreArray = GetScores(arrayOfData)

Private Function GetScores(ByVal arrayOfData As Variant) As Variant
Const SEARCH_SCORE As String = "Score"
Dim scoreIndex As Long
scoreIndex = 1
Dim scoreRows As Variant
Dim index As Long
For index = LBound(arrayOfData) To UBound(arrayOfData)
If arrayOfData(index) = SEARCH_SCORE Then
ReDim Preserve scoreRows(scoreIndex)
scoreRows(scoreIndex) = arrayOfData(index)
scoreIndex = scoreIndex + 1
End If
Next
End Function

Или что-то подобное, я не думаю, что это именно то, что вы делаете, но вы получаете идею.

1
ответ дан 6 марта 2018 в 05:03 Источник Поделиться

Главное, я бы рекомендовал отделять функционал программы на отдельные, специализированные подразделения. Попробуйте сделать эти как можно более общий характер, так что вы можете повторно использовать их в будущем. Я был в состоянии захватить большинство функциональности вашей программы с 7-8 функции/Сабы, которые потенциально могут быть использованы ... с небольшое или никакое изменения в будущих проектах.

Некоторые другие вещи, которые я заметил:


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

  • Как Raystafarian упоминалось, вы должны рассмотреть возможность возвращения значения/объекты функций вместо передачи ссылки byref в Сабы и их модификации

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

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

Option Explicit
Sub mainThing()

'Input file path and name of sheet containing pivot tables
Dim testFilePath As String
Dim pivotSheetName As String
testFilePath = "C:\file.xlsx"
pivotSheetName = "IQ_Pivot"

'Get raw excel data
Dim rawExcelData As Variant
rawExcelData = extractExcelData(testFilePath, pivotSheetName)

'Extract headers
Dim headerArr As Variant
headerArr = getHeaders(rawExcelData)

'Extract score data
Dim scoreArr As Variant
scoreArr = extractRows(rawExcelData, "Score", "Why?", 1)

'Do whatever else you want to in powerpoint

End Sub
Function extractExcelData(fPath As String, sheetName As String) As Variant
'Gets data from a single sheet (sheetName) of an Excel file (fPath) and returns as an array

'Create Excel application
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")

'Open workbook, or display error if workbook could not be open
'Optimize Excel calculation/visual settings
Dim xlWB As Object
Set xlWB = getWorkbook(xlApp, fPath)
If xlWB Is Nothing Then
xlApp.Quit
Set xlApp = Nothing
MsgBox ("Error: Could not open " & fPath)
Exit Function
End If
Call toggleSettings(xlApp, False)

'Get data from worksheet and close workbook
Dim excelData As Variant
excelData = getWSData(xlWB, sheetName)
xlWB.Close
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing

extractExcelData = excelData

End Function
Function getWSData(ByRef xlWB As Object, ByVal wsName As String) As Variant
'Returns array of data from a worksheet (wsName) in a workbook (xlWB)

Dim ws As Object
Set ws = xlWB.Sheets(wsName)

Dim lastRow As Long
Dim lastCol As Long
lastRow = getLastRow(ws)
lastCol = getLastColumn(ws)
getWSData = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value

End Function
Function getLastRow(ws As Object, Optional colNum As Long = 1) As Long

'Hard codes reference to xlUp (-4162) in case project uses late binding
getLastRow = ws.Cells(ws.Rows.Count, colNum).End(-4162).Row

End Function
Function getLastColumn(ws As Object, Optional rowNum As Long = 1) As Long

'Hard codes reference to xlToLeft (-4159) in case project uses late binding
getLastColumn = ws.Cells(rowNum, ws.Columns.Count).End(-4159).Column

End Function
Sub toggleSettings(xlApp As Object, turnOn As Boolean, Optional manualCalc As Boolean = False)
'Toggles various excel application settings to improve performance
'Hard codes references to xlCalculationManual (-4135) and xlCalculationAutomatic (-4105) in case project uses late binding

With xlApp
If manualCalc Then
.Calculation = -4135
.CalculateBeforeSave = False
Else
.Calculation = IIf(turnOn, -4105, -4135)
.CalculateBeforeSave = turnOn
End If
.DisplayAlerts = turnOn
.AskToUpdateLinks = turnOn
.DisplayStatusBar = turnOn
.ScreenUpdating = turnOn
.EnableAnimations = turnOn
End With

End Sub
Function getWorkbook(xlApp As Object, fileName As String, Optional asReadOnly As Boolean = True) As Object
'Return Excel workbook object, or nothing if file can't be opened

On Error Resume Next
Set getWorkbook = xlApp.Workbooks.Open(FileName:=fileName, _
UpdateLinks:=True, _
ReadOnly:=asReadOnly, _
Notify:=False)
On Error GoTo 0

End Function
Function getHeaders(arr As Variant) As Variant
'Extracts first row from an array

ReDim dataHeaders(LBound(arr, 2) To UBound(arr, 2)) As Variant
Dim i As Long
For i = LBound(dataHeaders) To UBound(dataHeaders)
dataHeaders(i) = arr(LBound(arr, 1), i)
Next

getHeaders = dataHeaders

End Function
Function extractRows(arr As Variant, startIndicator As String, endIndicator As String, Optional colNum As Long = 1, Optional includeIndicatorRows As Boolean = False) As Variant
'Extracts rows from a 2d array by searching for a start and end indicator in a column (colNum) of the array
'Returned array contains all rows between the indicator rows
'If includeIndicatorRows is True, returned array also includes the indicator rows

Dim i As Long
Dim j As Long
Dim x As Long

'Find start/end array row for data extraction
Dim startRow As Long
Dim endRow As Long
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = startIndicator Then
startRow = i + IIf(includeIndicatorRows, 0, 1)
ElseIf arr(i, colNum) = endIndicator Then
endRow = i - IIf(includeIndicatorRows, 0, 1)
Exit For
End If
Next

If startRow > endRow Then
Exit Function
End If

'Fill new array with identified rows
Dim numCols As Long
Dim numRows As Long
numCols = UBound(arr, 2)
numRows = endRow - startRow + 1
ReDim extractedData(1 To numRows, 1 To numCols) As Variant
x = 1
For i = startRow To endRow
For j = 1 To numCols
extractedData(x, j) = arr(i, j)
Next
x = x + 1
Next

extractRows = extractedData

End Function

0
ответ дан 6 марта 2018 в 07:03 Источник Поделиться