Копирование и размещение данных в Excel поля


Я создал этот код, который предназначается, чтобы вытащить конкретный доклад, который был сохранен в папку очистить (удалить) данные и добавить новые титулы, разделить информацию на одном из полей, а затем скопировать данные на новый лист с именем лист того, что поле на масштабируемой и переменной основе. Отчет может варьироваться от 10х20 до того 900x20 в зависимости от того, и само поле-это постоянно меняющаяся величина (это человек в компании, оборот происходит).

Я удалил некоторые из наиболее конфиденциальной информации. Как примечание, Я пытаюсь использовать многое из того, что было сказано мной в предыдущем вопрос по @мат'sMug, так что если есть практики мне не хватает, пожалуйста, дайте мне знать.

Option Explicit
Function SheetExists(sheetName As String, Optional Workbook As Workbook) As Boolean
    Dim sheet As Worksheet
' Checks if the workbook name exists in existing sheets.
     If Workbook Is Nothing Then Set Workbook = ThisWorkbook
     On Error Resume Next
     Set sheet = Workbook.Sheets(sheetName)
     On Error GoTo 0
     SheetExists = Not sheet Is Nothing
 End Function
Sub PO_Create()
' Initializes variables.
Dim lastRow As Integer
Dim lastCol As Integer
Dim weekStart As String
Dim dirFile As String
Dim terrName As String
Dim passProc As String
Dim wbClear As Object
Dim titleCol As Integer
Dim terrRow As Integer
Dim headers As Range
Dim dataRow As Integer
Dim newLine As Integer
Dim fileSave As String
Dim Infobox As Object

' Asks for the password to run the macro.
passProc = InputBox("Please enter the password to refresh the report.", _
    "Password Protected")
If passProc <> "Analyst!" Then
    MsgBox "Invalid password.", vbOKOnly
    Exit Sub
End If

' Turn off the screen and checks if the related file exists.
Application.ScreenUpdating = False
weekStart = Format(Admin.Cells(2, 3).Value, "mm-dd-yyyy")
dirFile = "C:\FileLocation " & _
    weekStart & ".xls"
If Dir(dirFile) = "" Then
    MsgBox "That file date was not found, please try a different date or rerun the report.", vbOKOnly
    Exit Sub
End If
Application.DisplayAlerts = False

' Clears all old data and sheets.
POList.Cells.ClearContents
For Each wbClear In ThisWorkbook.Worksheets
    If wbClear.Name <> "PO List" And wbClear.Name <> "Administration" Then
       wbClear.Delete
    End If
Next wbClear
Application.DisplayAlerts = True

' Opens the related workbook and trims unnecessary data.
Workbooks.Open (dirFile)
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For titleCol = lastCol To 1 Step -1
    If Cells(1, titleCol).Value <> "1" And _
        Cells(1, titleCol).Value <> "2" And _
        Cells(1, titleCol).Value <> "3" And _
        Cells(1, titleCol).Value <> "4" And _
        Cells(1, titleCol).Value <> "5" And _
        Cells(1, titleCol).Value <> "6" And _
        Cells(1, titleCol).Value <> "7" And _
        Cells(1, titleCol).Value <> "8" And _
        Cells(1, titleCol).Value <> "9" And _
        Cells(1, titleCol).Value <> "10" Then
    Columns(titleCol).EntireColumn.Delete
    End If
Next titleCol

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Copies and pastes the PO list information to the workbook.
ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
ThisWorkbook.Sheets("PO List").Activate
Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
POList.Range(Cells(1, 8), Cells(lastRow, 9)).Cut
Range(Cells(1, 1), Cells(lastRow, 2)).Insert (xlToRight)
Application.CutCopyMode = False
Selection.Columns.AutoFit

' Closes the PO list and focuses the window on the Report runner.
Workbooks("po list " & weekStart & ".xls").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Activate

' Renames column names.
Cells(1, 1).Value = "Territory"
Cells(1, 2).Value = "Name"
Cells(1, 3).Value = "PO Number"
Cells(1, 4).Value = "Vendor"
Cells(1, 5).Value = "Buyer"
Cells(1, 6).Value = "Order Date"
Cells(1, 7).Value = "Request Date"
Cells(1, 8).Value = "Job Number"
Cells(1, 9).Value = "Job Name"
Cells(1, 10).Value = "Job Task"

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Converts the numbers stored as text to numbers.
POList.Columns("A:A").Insert (xlShiftToRight)
For terrRow = 2 To lastRow
    Cells(terrRow, 1).Value = "=B" & terrRow & "*1"
Next terrRow
Range(Cells(2, 1), Cells(lastRow, 1)).Copy
Cells(2, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Cells(1, 1).EntireColumn.Delete (xlShiftToLeft)

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Loops through each line and sorts it to either a new sheet, or to an existing sheet.
Set headers = POList.Range(Cells(1, 1), Cells(1, lastCol))
For dataRow = 2 To lastRow
    terrName = Format(POList.Cells(dataRow, 1).Value)
    If SheetExists(terrName) Then
        ' Go to the end of that sheet and copy/paste the information.
        POList.Select
        Range(Cells(dataRow, 1), Cells(dataRow, lastCol)).Copy
        Sheets(terrName).Select
        newLine = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Columns.AutoFit
        POList.Select
    Else
        ' Create a new sheet, add headers, and copy the line.
        Sheets.Add.Name = terrName
        ActiveSheet.Tab.Color = 108
        headers.Copy
        Sheets(terrName).Select
        Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        POList.Select
        Range(Cells(dataRow, 1), Cells(dataRow, lastCol)).Copy
        Sheets(terrName).Select
        newLine = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Columns.AutoFit
        POList.Select
    End If
Next dataRow
' Save the worksheet with a new name and resets the workbook display properties.
Application.DisplayAlerts = False
fileSave = "C:\NewFileLocation " & _
    weekStart & " to " & Format(Admin.Cells(2, 3).Value + 4, "mm-dd-yyyy") & ".xlsm"
ThisWorkbook.SaveAs (fileSave)
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub
' This is where the code will go if an error occurs
Errhandler:
Set Infobox = CreateObject("Wscript.Shell")
Select Case Infobox.Popup( _
    "The code has encountered an error and needs to close." & _
    vbCrLf & vbCrLf & "Please contact the Financial Analyst with the error" 
    & vbCrLf & _
    "below." & vbCrLf & vbCrLf & _
    "Number: #" & Err.Number & vbCrLf & _
    "Error Description: " & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
    "Press OK or wait 5 seconds to close this.", 5, "Error!", 1)
    Case 1, -1
        Exit Sub
End Select
End Sub

Есть ли лучший способ сделать это, что по-прежнему позволяет для расширения?



124
1
задан 30 января 2018 в 07:01 Источник Поделиться
Комментарии
1 ответ

Объявление переменных прямо перед их использованием поможет вам вспомнить, для чего они нужны. Сверху у вас есть большой блок заявлений, прежде чем попасть в ваш код. Перемещая их туда, где они привыкают сделает его немного легче читать.

Если у вас есть номер в коде, что она из себя представляет? 108 существует и представляет собой нечто, но что? Использовать Const и назвал это число соответствующее имя. То же самое верно для 5 С Infobox. Это помогает самостоятельно документировать код.

Где у вас есть комментарий, который объясняет, что происходит, что это хорошая ставка, которую вы можете выполнить рефакторинг части кода в свой собственный суб/функция. Комментарий ' Renames column names. может стать RenameColumns и вы будете предоставлять его с листа йо uwant работать. Позвоните сайта, где он используется, похоже, RenameColumns POList. Вы теперь точно знаете, что происходит. Сам код должен самостоятельно документ, он должен сказать вам, что происходит. Комментарии, если они нужны, объяснять , почему это сделано в избранной форме.

Private Sub RenameColumns(ByVal renameSheet As Worksheet)
With renameSheet 'Value2 is slightly faster and doesn't have rounding issues
.Cells(1, 1).Value2 = "Territory"
.Cells(1, 2).Value2 = "Name"
.Cells(1, 3).Value2 = "PO Number"
.Cells(1, 4).Value2 = "Vendor"
.Cells(1, 5).Value2 = "Buyer"
.Cells(1, 6).Value2 = "Order Date"
.Cells(1, 7).Value2 = "Request Date"
.Cells(1, 8).Value2 = "Job Number"
.Cells(1, 9).Value2 = "Job Name"
.Cells(1, 10).Value2 = "Job Task"
End With
End Sub

Клетки теперь содержать имя листа, а не косвенно относящееся к параметру activesheet. Неявные диапазоны вызвать головную боль, потому что их легко упустить. Полностью определить их с переменной, которая представляет собой лист. worksheetVariable.Cells давайте вы знаете без сомнения, что листа он имеет в виду.

Ваш код, который следует' Turn off the screen and checks if the related file exists. скрывается возможный вопрос. Вы попали в Exit Sub и ScreenUpdating не будет снова включен. Только включите свойство screenupdating, если ваш охранник пункты были пройдены, и вы уверены, что ваш код может работать.

Ваш первый переработан метод от ' Clears all old data and sheets. это ClearOldDataAndSheets. Имя метода, который описывает, что он делает и дает понять, что будет происходить. Нейминг-это сложно и требуется время, чтобы придумать емкие названия. Я хотел бы предложить, используя CodeName собственность, а не Name. CodeName не вызовет вопросов, если вкладка переименовывается в Excel. В IDE F4 это тот же вид>свойства окне и позволит вам переименовать лист. (Имя) - это название, имя = TabName. Вы можете увидеть это в окне проекта, который он показал как CodeName (Name).

Private Sub ClearOldDataAndSheets()
Application.DisplayAlerts = False

Dim wbClear As Worksheet
' Clears all old data and sheets.
POList.Cells.ClearContents
For Each wbClear In ThisWorkbook.Worksheets
If wbClear.Name <> "PO List" And wbClear.Name <> "Administration" Then
wbClear.Delete
End If
Next wbClear
Application.DisplayAlerts = True
End Sub

Продолжая с комментарием замены ' Opens the related workbook and trims unnecessary data. становится TrimUnecessaryDataFrom. Теперь это функция, которая принимает в pathWithFilename и возвращает Workbook. Я изменил And для первой позиции после обрыва линии. С моим опытом это помогает не забывать, что это также логическое условие, которое проверяется. Полностью льготные. Это дает вам ваш урезанная книга.

Private Function TrimUnecessaryDataFrom(ByVal pathWithFilename As String) As Workbook

Dim bookToTrim As Workbook
Set bookToTrim = Workbooks.Open(pathWithFilename)

With bookToTrim.ActiveSheet
Dim lastCol As Long
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column

Dim titleCol As Long
For titleCol = lastCol To 1 Step -1
If .Cells(1, titleCol).Value <> "1" _
And .Cells(1, titleCol).Value <> "2" _
And .Cells(1, titleCol).Value <> "3" _
And .Cells(1, titleCol).Value <> "4" _
And .Cells(1, titleCol).Value <> "5" _
And .Cells(1, titleCol).Value <> "6" _
And .Cells(1, titleCol).Value <> "7" _
And .Cells(1, titleCol).Value <> "8" _
And .Cells(1, titleCol).Value <> "9" _
And .Cells(1, titleCol).Value <> "10" Then

.Columns(titleCol).EntireColumn.Delete
End If
Next titleCol
End With

Set TrimUnecessaryDataFrom = bookToTrim
End Function

Далее ' Copies and pastes the PO list information to the workbook. что будет CopyPOInfoFrom. У вас есть .Copy С .Activate (обратите внимание, что .Select одно и то же) с последующим неявно ссылаетесь Cells. Напрасно ActivateИнг можно избежать путем полного определения диапазона ссылки с листа на.

Private Sub CopyPOInfoFrom(ByVal copyFromSheet As Worksheet)
' Reinitializes the last cells.
Dim lastRow As Long
Dim lastCol As Long
lastRow = copyFromSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastCol = copyFromSheet.Cells(1, Columns.Count).End(xlToLeft).Column

' Copies and pastes the PO list information to the workbook.
copyFromSheet.Range(copyFromSheet.Cells(1, 1), copyFromSheet.Cells(lastRow, lastCol)).Copy
POList.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

Application.CutCopyMode = False
Dim cutRange As Range
Set cutRange = POList.Range(POList.Cells(1, 8), POList.Cells(lastRow, 9))
cutRange.Cut
POList.Cells(1, 1).Resize(cutRange.Rows.Count, cutRange.Columns.Count).Insert xlToRight
Application.CutCopyMode = False
Selection.Columns.AutoFit
End Sub

Когда подлодку закончена у вас есть информация перешел. RenameColumns следует, и это было объяснено.

' Converts the numbers stored as text to numbers. становится ConvertsNumbersStoredAsTextToNumbers и вы предоставляете аргумент для листа, с которым вы хотите работать. Были созданы, чтобы упростить логику того, что вы работаете с несколько вспомогательных переменных.

Private Sub ConvertsNumbersStoredAsTextToNumbers(ByVal sheetToWorkWith As Worksheet)
With sheetToWorkWith
Dim lastRow As Long
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

Dim textNumbers As Range
Set textNumbers = .Range(.Cells(2, 1), .Cells(lastRow, 1))
sheetToWorkWith.Columns("A:A").Insert xlShiftToRight

Dim numberRange As Range
Set numberRange = sheetToWorkWith.Cells(2, 1).Resize(textNumbers.Rows.Count)
numberRange.Formula = "=" & textNumbers.Cells(1, 1).Address(False, False) & "*1"
numberRange.Copy
textNumbers.PasteSpecial xlPasteValuesAndNumberFormats

.Columns(1).Delete xlShiftToLeft
End With
End Sub

' Loops through each line and sorts it to either a new sheet, or to an existing sheet. становится MoveInformationToAppropriateLocation. И то же самое для спасения книги.

Перемещение Суб

Private Sub MoveInformationToAppropriateLocation(ByVal sheetToWorkWith As Worksheet)
With sheetToWorkWith
Dim moveToSheet As Worksheet
' Reinitializes the last cells.
Dim lastRow As Long
Dim lastCol As Long
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column

Dim columnSpan As Long
columnSpan = lastCol
' Loops through each line and sorts it to either a new sheet, or to an existing sheet.
Dim headers As Range
Set headers = .Cells(1, 1).Resize(ColumnSize:=columnSpan)

Dim newLine As Long
Dim dataRow As Long
For dataRow = 2 To lastRow
Dim terrName As String
terrName = Format$(.Cells(dataRow, 1).Value2)
If SheetExists(terrName) Then
' Go to the end of that sheet and copy/paste the information.
POList.Cells(dataRow, 1).Resize(ColumnSize:=columnSpan).Copy
Set moveToSheet = Worksheets(terrName)
newLine = moveToSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
moveToSheet.Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
' Create a new sheet, add headers, and copy the line.
Set moveToSheet = ThisWorkbook.Worksheets.Add
moveToSheet.Name = terrName
Const MAROON As Long = 108
moveToSheet.Tab.Color = MAROON
headers.Copy
moveToSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
POList.Cells(dataRow, 1).Resize(ColumnSize:=columnSpan).Copy
moveToSheet.Cells(1 + headers.Rows.Count, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next dataRow
End With

moveToSheet.Columns.AutoFit
End Sub

Суб Экономии

Private Sub SaveFileWithName(ByVal saveName As String)
Application.DisplayAlerts = False
ThisWorkbook.SaveAs saveName
Application.DisplayAlerts = True
End Sub

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

Public Sub PO_Create()
On Error GoTo Errhandler
' Asks for the password to run the macro.
Dim passProc As String
passProc = InputBox("Please enter the password to refresh the report.", "Password Protected")
If passProc <> "Analyst!" Then
MsgBox "Invalid password.", vbOKOnly
Exit Sub
End If

' Does related file exist?
Dim weekStart As String
weekStart = Format$(Admin.Cells(2, 3).Value, "mm-dd-yyyy")
Dim dirFile As String
dirFile = "C:\FileLocation " & weekStart & ".xls"
If Dir(dirFile) = vbNullString Then
MsgBox "That file date was not found, please try a different date or rerun the report.", vbOKOnly
Exit Sub
End If

Application.ScreenUpdating = False

'TODO: This can be refactorerd (https://en.wikipedia.org/wiki/Code_refactoring)
'to have 'CopyPOInfoFrom' to be the only part visible. Everything else will be called
'from that that leaving one line visible here
ClearOldDataAndSheets
Dim POWorkbook As Workbook
Set POWorkbook = TrimUnecessaryDataFrom(dirFile)
CopyPOInfoFrom POWorkbook.ActiveSheet
Application.DisplayAlerts = False
POWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Activate

RenameColumns POList
ConvertsNumbersStoredAsTextToNumbers POList
MoveInformationToAppropriateLocation POList

Dim fileSave As String
fileSave = "C:\NewFileLocation " & weekStart & " to " & Format$(Admin.Cells(2, 3).Value + 4, "mm-dd-yyyy") & ".xlsm"
SaveFileWithName fileSave

Application.ScreenUpdating = True
Exit Sub

Errhandler:
Dim Infobox As Object
Set Infobox = CreateObject("Wscript.Shell")
Dim msg As String
msg = "The code has encountered an error and needs to close." & vbCrLf & vbCrLf & _
"Please contact the Financial Analyst with the error" & vbCrLf & "below." & vbCrLf & vbCrLf & _
"Number: #" & Err.Number & vbCrLf & _
"Error Description: " & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"Press OK or wait 5 seconds to close this."
Const WAIT_TIME_BEFORE_AUTO_CLOSE As Long = 5
Select Case Infobox.Popup(msg, WAIT_TIME_BEFORE_AUTO_CLOSE, "Error!", 1)
Case 1, -1
Exit Sub
End Select
End Sub

Наконец. Я http://rubberduckvba.com забрать на следующий, что я пропустил. Примечание: Я автор, спасибо @мат'sMug и это помогло мне много. Для меня Rubberduck является незаменимым инструментом, и я ни о чем не жалеют об этом.


  • У вас есть метка линия Errhandler, но это не везде. On Error GoTo Errhandler

  • В вашей функции SheetExists параметры передаются по ссылке. Я не видел их установить, чтобы они могли быть переданы ByVal

1
ответ дан 30 января 2018 в 11:01 Источник Поделиться