Проверка минимального значения в столбце и копирование всех данных после этого минимального значения - PullRequest
Новая
       32

Проверка минимального значения в столбце и копирование всех данных после этого минимального значения

0 голосов
/ 06 декабря 2018

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

Обратитесь сюда для получения информации онемного фона о том, что я делаю: Установка Excel Excel в переменную и вызов переменной в другой под

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

Вот код, который у меня сейчас есть: 

Public Path As String
Public Counter As Integer
Public NameFile As Workbook
Public Celltxt As String 'Checks cell value in D2, used to compare to Strings to confirm part type
Public MyFolder As String 'Path collected from the folder picker dialog
Public MyFile As String 'Filename obtained by DIR function
Public wbk As Workbook 'Used to loop through each workbook
Public thisWb As Workbook
Public MasterFile As String
Public Min As Variant

Sub Consolidate_Diagramms_Data()

Dim wb As Workbook

Dim TestStr As String

TestStr = ""

TestStr = Dir("C:\DataAnalyzation\Consolidated Diagramm Data.xlsx")

Application.DisplayAlerts = False

If TestStr = "" Then

    Set NameFile = Workbooks.Add

    NameFile.SaveAs Filename:="C:\DataAnalyzation\Consolidated Diagramm Data.xlsx"

    Range("A1").Value = "Part Number"

    Range("B1").Value = "Date"

    Range("C1").Value = "Time"

    Range("D1").Value = "Part Type"

    Range("E1").Value = "Comment"

    Range("F1").Value = "Zero"

    Else

    Workbooks.Open Filename:="C:\DataAnalyzation\Consolidated Diagramm Data.xlsx"

    Range("A1").Value = "Part Number"

    Range("B1").Value = "Date"

    Range("C1").Value = "Time"

    Range("D1").Value = "Part Type"

    Range("E1").Value = "Comment"

    Range("F1").Value = "Zero"

End If

MasterFile = "C:\DataAnalyzation\Consolidated Diagramm Data.xlsx"

Call AllWorkbooks

End Sub

Sub AllWorkbooks()

Dim LastRow As Long

Dim minRange As Variant

Set thisWb = ActiveWorkbook

'On Error Resume Next

Application.ScreenUpdating = False 'Opens the folder picker dialog to allow user selection

MsgBox "Please select the folder from which you wish to consolidate your data."

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Please select a folder"

.Show

.AllowMultiSelect = False

   If .SelectedItems.Count = 0 Then 'If no folder is selected, abort

MsgBox "You did not select a folder"

      Exit Sub

   End If

MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder

End With

Counter = 0

LHCounter = 0

RHCounter = 0

FeedshaftCounter = 0

MyFile = Dir(MyFolder) 'DIR gets the first file of the folder

'Loop through all files in a folder until DIR cannot find anymore

Do While MyFile <> ""

    LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

    Counter = Counter + 1

    Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

    'Copy Part Number, Date, Time, Part Type, and Comment

    Workbooks(MyFile).Activate 'Activates the Data Sheet

    If Range("B1").Value = "" Then

        GoTo Nd

    End If

    ActiveSheet.Range("A2:E2").Copy 'Copies the Part Number, Date, Time and Part Type

    'Paste Part Number, Date, Time, Part Type, and Comment

    Workbooks("Consolidated Diagramm Data.xlsx").Activate 'Activates the final Workbook

    Range("A" & LastRow).PasteSpecial Paste:=xlPasteAll 'Pastes the Date into "A2"

    Application.CutCopyMode = False

    'Copy Force

    Workbooks(MyFile).Activate

    Range("D4").Activate

    minRange = Application.WorksheetFunction.Min(Sheets(1).Range("D4:D500"))

    minRange.Activate

    ActiveCell.End(xlDown).Copy

    Workbooks("Consolidated Diagramm Data.xlsx").Activate

    Range("F" & LastRow).Activate

    ActiveCell.PasteSpecial Paste:=xlPasteAll, Transpose:=True

    Application.CutCopyMode = False

    GoTo Nd

    'End of Copy/Paste coding

Nd:

wbk.Close savechanges:=False

MyFile = Dir 'DIR gets the next file in the folder

Loop

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox ("A total of " & Counter & " files have been consolidated.")

End Sub

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

В строках: 

    minRange = Application.WorksheetFunction.Min(Sheets(1).Range("D4:D500"))

    minRange.Activate

Я получаю сообщение об ошибке «Runtime Error '424': Object Required».

Ниже приведена обновленная часть моего кода, гдеЯ ищу минимальное значение.В настоящее время я получаю «Run-time 1004: Невозможно получить свойство Match класса WorksheetFunction».

Workbooks(MyFile).Activate

    Range("D4").Activate

    Set myRng = Range("D4:D" & Rows.Count)

    minValue = Application.WorksheetFunction.Min(myRng)

    myRow = Application.WorksheetFunction.Match(minValue, myRng, 0)

    Range(myRow, myRng).Activate

    ActiveCell.End(xlDown).Copy

    Workbooks("Consolidated Diagramm Data.xlsx").Activate

    Range("F" & LastRow).Activate

    ActiveCell.PasteSpecial Paste:=xlPasteAll, Transpose:=True

    Application.CutCopyMode = False

    GoTo Nd

1 Ответ

0 голосов
/ 06 декабря 2018

Следующая строка даст вам строку минимального значения (при условии, что она только одна): 

Dim myRng As Range
Dim myRow as Long
Dim minValue as Long
Set myRng = Range("A1:A" & Rows.Count)
minValue = Application.WorksheetFunction.Min(myRng)
MyRow = Application.WorksheetFunction.Match(minValue, myRng, 0)
...