Возьмите данные с одного листа и вставка/формат его в другой лист


У меня есть код, который работает и делает то, что я хочу это делать с помощью нажатия кнопки, но при выполнении, он работает очень медленно.

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

Я еще новичок с кодированием VBA и любых направлении или помочь сделать код работать быстрее, ценится или способов удаления ненужного кода, поскольку это, вероятно, больше, чем он должен быть.

Public Sub Button1_Click() ' Update Button

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lastRowPart As Long
Dim lastRowCW As Long
Dim lastRowQty As Long
Dim lastRowQtyLeft As Long
Dim lastRowDescrip As Long
Dim i, j, k As Integer
Dim IO As Worksheet: Set IO = Sheets("Inventory Overview")
Dim TD As Worksheet: Set TD = Sheets("Trend Data")

'1. Copies and formats data

lastRowPart = IO.Cells(Rows.count, "F").End(xlUp).Row
lastRowDescrip = IO.Cells(Rows.count, "G").End(xlUp).Row
lastRowQtyLeft = IO.Cells(Rows.count, "O").End(xlUp).Row
lastRowQty = IO.Cells(Rows.count, "I").End(xlUp).Row
lastRowCW = IO.Cells(Rows.count, "L").End(xlUp).Row

TD.Cells.UnMerge ' reset***

j = 2
k = 2
For i = 2 To lastRowCW
If IO.Cells(i, "L").Value = "Unknown" Then
    TD.Cells(j, "G").Value = IO.Cells(i, "L").Value
    TD.Cells(j, "H").Value = IO.Cells(i, "F").Value
    TD.Cells(j, "I").Value = IO.Cells(i, "I").Value
    TD.Cells(j, "J").Value = IO.Cells(i, "O").Value
    TD.Cells(j, "K").Value = IO.Cells(i, "G").Value
    j = j + 1
Else
    TD.Cells(k, "A").Value = IO.Cells(i, "L").Value
    TD.Cells(k, "B").Value = IO.Cells(i, "F").Value
    TD.Cells(k, "C").Value = IO.Cells(i, "I").Value
    TD.Cells(k, "D").Value = IO.Cells(i, "O").Value
    TD.Cells(k, "E").Value = IO.Cells(i, "G").Value
    k = k + 1
End If
Next

' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit

'2. Sort Cells
Dim LastRow As Long
LastRow = TD.Cells(Rows.count, 5).End(xlUp).Row

With TD.Sort  ' sorts data from A to Z
 .SetRange TD.range("A2:E" & LastRow)
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
End With

'3. Merge CW Cells
' rngMerge = range for parts reworked/left with known CW
' URngMerge = range for parts reported with unknown CW

Dim rngMerge As range, URngMerge As range, cell As range, lastRowMerge As   Long, ULastRowMerge As Long
lastRowMerge = TD.Cells(Rows.count, 1).End(xlUp).Row
ULastRowMerge = TD.Cells(Rows.count, 7).End(xlUp).Row
Set rngMerge = TD.range("A1:A" & lastRowMerge)
Set URngMerge = TD.range("G1:G" & ULastRowMerge)

MergeAgain:
For Each cell In rngMerge
    If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
        range(cell, cell.Offset(1, 0)).Merge
        GoTo MergeAgain
End If
Next

MergeAgain2:
For Each cell In URngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
    range(cell, cell.Offset(1, 0)).Merge
    GoTo MergeAgain2
End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Комментарии
2 ответа

Хорошая работа, вы dceclared все переменные и ваши имена переменных будут довольно описательной. Одно


Dim i, j, k as Integer

Это только k как целое, они двух других вариантов. Нужно ввести их все:

Dim i as Long, Dim j as Long, Dim k as Long

Я пошел с Long типа, потому что целые числа являются устаревшими. По данным на MSDN ВБА молча преобразует все числа в long.

Одним придираться будет Dim LastRow As Long - стандартные соглашения об именах в VBA есть camelCase для локальных переменных и PascalCase для других переменных и имена. Так lastRow.

У вас также есть rngMerge и UrngMerge - может быть более описательным в эти имена.

Всегда включаю Option Explicit. Вы можете иметь его автоматически, зайдя в Инструменты -> Параметры в программу и проверки требуют переменной вариант. Таким образом, если у вас есть какие-либо переменные не определен, компилятор даст вам знать.

Листы имеют CodeName свойства - просмотр свойств окна (Ф4) и (Name) поля (в верхней части) может быть использован как имя листа. Таким образом, вы можете избежать Sheets("Trend Data") и вместо того, чтобы просто использовать TrendData.

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


Говоря о вашей этикетки


MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next

MergeAgain2:
For Each cell In URngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain2
End If
Next


Это странный способ сделать это зацикливание.

For j = LastRow To startrow Step -1
If (.Cells(j, col) = .Cells(j + 1, col)) And Not IsEmpty(.Cells(j, col)) Then .Range(.Cells(j, col), .Cells(j + 1, col)).Merge
Next

Никаких причин, чтобы использовать этикетки, если есть лучший способ сделать это.

Вы видите, когда вы используете булевы функции, как IsEmptyвам не нужно, чтобы проверить его ценность именно потому, что If ищет правда или ложь уже.

Скорость

Единственный способ, чтобы действительно получить скорость здесь, чтобы вытащить ваши данные в массивы и делать свои операции на те, затем выплюнуть всю массивов на лист.

Я не совсем уверен в своей цели с .Merge но они являются вашим естественным врагом. Поверь мне. Было бы лучше, чтобы группа клеток и .HorizontalAlignment = xlHAlignCenterAcrossSelection

2
ответ дан 20 марта 2018 в 08:03 Источник Поделиться

Вы получите более качественный ответ, если вы разместите пример данных и/или скриншоты или ссылку на скачивание с образца книги.

Вам нужен RubberDuck. Скачать RubberDuck имеет код форматирования, что является бесценным (и многое, многое другое!!). Вы должны автоматически форматировать код часто. Это поможет вам поймать конец блока кода рассогласования и сделать код более читабельным.

j и 'K' не нужны, потому что они будут всегда равны i.

For i = 2 To lastRowCW
If IO.Cells(i, "L").Value = "Unknown" Then
j = j + 1
Else
k = k + 1
End If
Next

Почему '.Заголовок = xlGuess'?

With TD.Sort  ' sorts data from A to Z
.SetRange TD.Range("A2:E" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Предполагая, что данные заголовки в .Range("A1:E1") использование:

With TD.Sort  ' sorts data from A to Z
.SetRange TD.Range("A1:E" & LastRow)
.Header = xlYes

GoTo заявление лучше всего зарезервировано для обработки ошибок. Хотя GoTo MergeAgain логика проще выполнять это заставляет вас придется повторить за те же клетки несколько раз. В моем примере кода ниже я покажу, как избежать его с помощью переменной диапазона.

MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next

Application.Calculation = xlCalculationManual потенциально может ускорить ваш код.

Чтение данных из массива, а не непосредственно из клеток даст небольшой прирост в производительности. Писать все значения в одной операции, используя массив, обеспечит значительное увеличение производительности.

Избежать именования переменных после существующих встроенных объектов.

В какой-то момент во время написания кода Вы имели переменной range что все строчные буквы. Я знаю это, потому что диапазон неправильно оприходовали.
Добавление Dim Range в верхней части кода модуля, а затем удалить его будет исправить капитализации на протяжении всего проекта.

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

Нет никаких преимуществ для автоматического размещения определенных диапазонов.

' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit

Простой автоподбор всей колонны.

TD.Range("B1,E1,H1,K1").EntireColumn.AutoFit

Рефакторинг Кода

Public Sub Button1_Click()
Dim LastRow As Long
Dim data As Variant
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With ThisWorkbook.Worksheets("Trend Data")
TrendDataClear
data = getInventory
.Range("A2").Resize(UBound(data, 1), UBound(data, 2)).Value = data
TrendDataSort
MergeCells 1, .Cells.Worksheet
MergeCells "G", .Cells.Worksheet
.Range("B1,E1,H1,K1").EntireColumn.AutoFit
End With

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Private Function getInventory() As Variant
Dim i As Long, LastRow As Long
Dim results As Variant

With ThisWorkbook.Worksheets("Inventory Overview")
LastRow = .Cells(Rows.Count, "L").End(xlUp).Row
ReDim results(1 To LastRow - 1, 1 To 11)

For i = 2 To LastRow
If .Cells(i, "L").Value = "Unknown" Then
results(i - 1, 7) = .Cells(i, "L").Value
results(i - 1, 8) = .Cells(i, "F").Value
results(i - 1, 9) = .Cells(i, "I").Value
results(i - 1, 10) = .Cells(i, "O").Value
results(i - 1, 11) = .Cells(i, "G").Value
Else
results(i - 1, 1) = .Cells(i, "L").Value
results(i - 1, 2) = .Cells(i, "F").Value
results(i - 1, 3) = .Cells(i, "I").Value
results(i - 1, 4) = .Cells(i, "O").Value
results(i - 1, 5) = .Cells(i, "G").Value
End If
Next
End With

getInventory = results
End Function

Private Sub MergeCells(vColumn As Variant, ws As Worksheet)
Dim cell As Range, Target As Range
With ws
For Each cell In .Range(.Cells(2, vColumn), .Cells(.Rows.Count, vColumn).End(xlUp))
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
If Target Is Nothing Then
Set Target = Range(cell, cell.Offset(1))
Else
Set Target = Range(Target, cell.Offset(1))
End If
Else
If Not Target Is Nothing Then
Target.Merge
Set Target = Nothing
End If
End If
Next
If Not Target Is Nothing Then Target.Merge
End With
End Sub

Private Sub TrendDataClear()
Dim Target As Range
With ThisWorkbook.Worksheets("Trend Data")
Set Target = Intersect(.UsedRange, .UsedRange.Offset(1))
If Not Target Is Nothing Then
Target.UnMerge
Target.ClearContents
End If
End With
End Sub

Private Sub TrendDataSort()
With ThisWorkbook.Worksheets("Trend Data")
.Sort.SetRange .Range("A1:E1").Resize(Cells(Rows.Count, "L").End(xlUp).Row)
With .Sort ' sorts data from A to Z
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub

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