Мне нужна чья-то помощь, чтобы объединить мой код VBA для электронной таблицы на работе

Question

поэтому я писал код на своей работе, чтобы взять файл .csv и вытащить данные из него в таблицы данных, в которых уже есть указанные столбцы. Я никогда не посещал какие-либо курсы VBA или что-то еще, это все, что я нашел на форумах, которые были объединены. В настоящее время это работает, но иногда это ломается и вылетает Excel. Из того, что я нашел, похоже, мне нужно консолидировать это, поэтому я публикую это здесь, чтобы посмотреть, есть ли кто-то с большим знанием, который мог бы помочь мне сделать это. Это было очень сложно. Некоторые из проблем, с которыми я столкнулся, были при копировании из не объединенной ячейки в объединенную ячейку, использование одной ячейки для изменения пути к файлу, при котором файл открывается как новая таблица данных, и использование InStr для поиска правильного столбца ячеек для извлечения данных. от. Кроме того, иногда существует только один набор данных, в этих случаях мне нужно было иметь возможность извлекать эти данные, но использование xldown выбирало все ячейки, поэтому я создал оператор if. Смотрите код ниже.

''Finds data from results and brings it into datasheet
Sub Update_Data_Click()

''Sets up Variables

    Dim Job As String
    Dim Year As String
    Dim Folder As String
    Dim TestResults As String
    Dim Sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim SampleID As Range
    Dim UTS As Range
    Dim YS As Range
    Dim ELG As Range
    Dim UTF As Range
    Dim YF As Range


Worksheets("Tensile Ext").Rows(37 & ":" & Worksheets("Tensile Ext").Rows.Count).Delete
Worksheets("Tensile Ext").Rows("21:36").ClearContents

''Change year here each year

    Job = Range("S2")
    Year = 2020
    Folder = "D-MaterialsTesting"
    TestResults = "TestResults"

 ''Finds Job folder with from support data
    Application.ScreenUpdating = False
    Workbooks.OpenText Filename:="S:" & "\" & Folder & "\" & Year & "\" & Job & "\" & "TestResults" & ".csv", DataType:=xlDelimited, comma:=True
    With ActiveWorkbook
        .ActiveSheet.Copy After:=ThisWorkbook.Sheets(Sheets.Count)
        .Close
    End With
    Cells.Select
    Cells.EntireColumn.AutoFit


    Sheets("TestResults").Select
    Range("A2").Select
 If ActiveSheet.UsedRange.Rows.Count = 2 Then

    ''Copies Sample ID Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("A21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each SampleID In Range("A1:I1")
        DoEvents
        If InStr(SampleID.Value, "Sample ID") > 0 Then
            SampleID.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("A21").Select
            ActiveSheet.Paste
        End If
    Next SampleID
    Range("A21:D21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''Copies Ultimate Force from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("N21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTF In Range("A1:I1")
        If InStr(UTF.Value, "Ultimate Force") > 0 Then
            UTF.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("N21").Select
            ActiveSheet.Paste
        End If
    Next UTF

    Range("N21:Q21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''Copies Yield Force Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("R21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YF In Range("A1:I1")
        If InStr(YF.Value, "Offset Force") > 0 Then
            YF.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("R21").Select
            ActiveSheet.Paste
        End If
    Next YF

    Range("R21:U21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''Copies Ultimate Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("V21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTS In Range("A1:I1")
        If InStr(UTS.Value, "Ultimate Stress") > 0 Then
            UTS.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("V21").Select
            ActiveSheet.Paste
        End If
    Next UTS

    Range("V21:Y21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''Copies Yield Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("Z21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YS In Range("A1:I1")
        If InStr(YS.Value, "Offset Stress") > 0 Then
            YS.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("Z21").Select
            ActiveSheet.Paste
        End If
    Next YS

    Range("Z21:AC21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''Copies Elongation Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("AD21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each ELG In Range("A1:I1")
        If InStr(ELG.Value, "Elongation") > 0 Then
            ELG.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("AD21").Select
            ActiveSheet.Paste
        End If
    Next ELG

    Range("AD21:AE21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

    ''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

 ElseIf Range(Selection, Selection.End(xlDown)).Count < 2000 Then

''Copies Sample ID Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("A21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each SampleID In Range("A1:I1")
        If InStr(SampleID.Value, "Sample ID") > 0 Then
            SampleID.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("A21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next SampleID

    Range("A21:D21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Ultimate Force Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("N21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTF In Range("A1:I1")
        If InStr(UTF.Value, "Ultimate Force") > 0 Then
            UTF.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("N21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next UTF

    Range("N21:Q21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Yield Force Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("R21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YF In Range("A1:I1")
        If InStr(YF.Value, "Offset Force") > 0 Then
            YF.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("R21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next YF

    Range("R21:U21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Ultimate Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("V21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTS In Range("A1:I1")
        If InStr(UTS.Value, "Ultimate Stress") > 0 Then
            UTS.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("V21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next UTS

    Range("V21:Y21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Yield Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("Z21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YS In Range("A1:I1")
        If InStr(YS.Value, "Offset Stress") > 0 Then
            YS.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("Z21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next YS

    Range("Z21:AC21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Elongation Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("AD21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each ELG In Range("A1:I1")
        If InStr(ELG.Value, "Elongation") > 0 Then
            ELG.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("AD21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next ELG

    Range("AD21:AE21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault


''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End If

End Sub

Answer 1

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

Чтобы избежать подобных комментариев в будущем, пожалуйста, научитесь разбивать ваш код на Main, возможно, 20 или 30 строк, которые вызывают подпрограммы и функции, каждая из которых, как правило, не длиннее 15–20 строк.

Итак, я начал просматривать ваш код и советовал вам «не выбирайте и не активируйте ничего ». Если вы прислушаетесь к этому совету, ваш код сократится примерно вдвое. Затем я нашел огромный блок кода, который повторяется. Для этого я создал подпрограмму, которая затем вызывается шесть раз с различными параметрами. Здесь вы учитесь обрабатывать повторы.

После этого я столкнулся с ElseIf, которого раньше не встречал. Я добавил комментарий в If о том, что блок IF был слишком большим. Я был прав в этом. Затем я увидел то, что казалось очередной серией повторений, из-за которой я собрал баланс.

1. Изменения, которые я сделал, слишком значительны, чтобы их можно было совершить без ошибок. Мой код нуждается в тестировании, которое я не могу выполнить из-за нехватки данных.
2. Настройка другой подпрограммы будет именно тем, что вам нужно изучить. Для меня нет никакой пользы в этом.
3. Никто не лучше подходит для решения ElseIf, чем вы сами. Этот проект должен вернуться к вам на попечение. Вот оно - как есть. Но еще одно замечание перед I go: вы можете «перерабатывать» переменные одного типа. Например, ваши диапазоны UTF и UTS, похоже, не должны сохранять свои изначально присвоенные значения. Таким образом, одна переменная, вероятно, может выполнять работу с ними обоими, одну работу за другой. Если вам больше не нужно значение, переменная может быть переназначена для другого использования.

Извините, мне не удалось получить весь код между тегами кода. Система не будет этого делать. Пожалуйста, скопируйте все, что ниже этого абзаца, и отсортируйте строки в редакторе VB.

Sub Update_Data_Click()

    Dim WsTe As Worksheet               ' "Tensile Ext"
    Dim WsTr As Worksheet               ' "Test Result"
    Dim Job As String
    Dim Year As String
    Dim Folder As String
    Dim TestResults As String
    Dim Sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim SampleID As Range
    Dim UTS As Range, UTF As Range
    Dim YS As Range, YF As Range
    Dim ELG As Range
    Dim Tmp As Variant                  ' for intermediate use

    Set WsTe = Worksheets("Tensile Ext")        ' it seems you will use this sheet again
    Set WsTr = Worksheets("TestResult")         ' list Ws declarations together for easy reference

    With WsTe
        ' determine last used row in column A
        Last = .Cells(.Rows.Count, "A").End(xlUp).Row
        ' deleting 1.4 million rows is both excessive and impossible
'        .Rows(37 & ":" & .Rows.Count).Delete
        .Range(.Rows(37), .Rows(Last)).Delete
        .Rows("21:36").ClearContents
    End With

    Job = Range("S2").Value                     ' always specify the property
    Year = 2020                                 ' Change year here each year
    Folder = "D-MaterialsTesting"
    TestResults = "TestResults"

   ' Find Job folder with from support data
    Application.ScreenUpdating = False
    ' creating the string before you use it makes code
    ' more readable and easier to trouble shoot
    Tmp = "S:" & "\" & Folder & "\" & Year & "\" & Job & "\" & "TestResults" & ".csv"
    Workbooks.OpenText Filename:=Tmp, DataType:=xlDelimited, Comma:=True
    With ActiveWorkbook
        ' I would prefer Worksheets(1).Copy
        ' effectively, there is no telling which sheet will be active
        .ActiveSheet.Copy After:=ThisWorkbook.Sheets(Sheets.Count)
        .Close
    End With

    ' big mistake here!
    ' Worksheet isn't identified, which specifies the ActiveSheet
    ' I presume this to be WsTe most of the time but it's a lottery
'    Cells.Select                               ' don't Select anything
    Cells.EntireColumn.AutoFit

    ' don't select or activate anything!
    ' instead, name the worksheets and address them by your variable names
'    Sheets("TestResults").Select
'    Range("A2").Select
    ' this IF block is too large, perhaps therefore also End If misplaced
    ' UsedRange is unreliable!
'    If ActiveSheet.UsedRange.Rows.Count = 2 Then
    With WsTr
        ' using column A to determine last used row
        If .Cells(.Rows.Count, "A").End(xlUp).Row > 2 Then GoTo Skip
    End With

    CopyResultData "Sample ID", WsTe.Range("A21:D21"), WsTe, WsTr
    CopyResultData "Ultimate Force", WsTe.Range("N21:Q21"), WsTe, WsTr
    CopyResultData "Offset Force", WsTe.Range("R21:U21"), WsTe, WsTr
    CopyResultData "Ultimate Stress", WsTe.Range("V21:Y21"), WsTe, WsTr
    CopyResultData "Offset Stress", WsTe.Range("Z21:AC21"), WsTe, WsTr
    CopyResultData "Elongation", WsTe.Range("AD21:AE21"), WsTe, WsTr


    ' ============================================================
    ' This is where I terminated my review
    ' The ElseIf below isn't connected to any IF above.
    ' ============================================================


    ''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

 ElseIf Range(Selection, Selection.End(xlDown)).Count < 2000 Then

''Copies Sample ID Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("A21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each SampleID In Range("A1:I1")
        If InStr(SampleID.Value, "Sample ID") > 0 Then
            SampleID.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("A21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next SampleID

    Range("A21:D21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Ultimate Force Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("N21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTF In Range("A1:I1")
        If InStr(UTF.Value, "Ultimate Force") > 0 Then
            UTF.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("N21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next UTF

    Range("N21:Q21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Yield Force Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("R21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YF In Range("A1:I1")
        If InStr(YF.Value, "Offset Force") > 0 Then
            YF.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("R21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next YF

    Range("R21:U21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Ultimate Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("V21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each UTS In Range("A1:I1")
        If InStr(UTS.Value, "Ultimate Stress") > 0 Then
            UTS.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("V21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next UTS

    Range("V21:Y21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Yield Stress Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("Z21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each YS In Range("A1:I1")
        If InStr(YS.Value, "Offset Stress") > 0 Then
            YS.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("Z21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next YS

    Range("Z21:AC21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''Copies Elongation Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("AD21").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each ELG In Range("A1:I1")
        If InStr(ELG.Value, "Elongation") > 0 Then
            ELG.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("AD21").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste
        End If
    Next ELG

    Range("AD21:AE21").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge
    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault

''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True

Skip:
    Application.ScreenUpdating = True
End Sub

Private Sub CopyResultData(Itm As String, _
                           Rng As Range, _
                           WsTe As Worksheet, _
                           WsTr As Worksheet)
' Copies Itm Data from TestResults Datasheet

    Dim Cell As Range

    With WsTe
        ' next 9 lines are your original code which I commented
        ' and moved from your Main sub here.
        ' Just to show the development. Take note and delete:-
'        Sheets("Tensile Ext").Select                ' don't select anything
'        Range("A21").Select
'        Range(Selection, Selection.End(xlDown)).Select
'        Selection.UnMerge
'        ' xlDown will find the first empty cell after A21
'        ' your code includes that blank cell in the unmerge
'        .Range(.Cells(21, "A"), .Cells(21, "A").End(xlDown)).UnMerge
'        ' xlUp will find the first non-empty cell above "A" last row
''        .Range(.Cells(21, "A"), .Cells(.Rows.Count, "A").End(xlUp)).UnMerge

        ' the next 3 lines perform the same work as the above
        ' but within the requirement of this procedure
        .Range(Rng.Cells(1), Rng.Cells(1).End(xlDown)).UnMerge
        ' use either the above or the below
'        .Range(Rng.Cells(1), Rng.Cells(1).End(xlUp)).UnMerge
    End With

'    Sheets("TestResults").Select                ' don't select anything
    For Each Cell In WsTr.Range("A1:I1")
'        DoEvents                                ' why's that?
        If InStr(Cell.Value, Itm) > 0 Then
'            Cell.Offset(1, 0).Select
'            Selection.Copy
            Cell.Offset(1, 0).Copy _
                     Destination:=WsTe.Cells(WsTe.Rows.Count, Rng.Column).End(xlUp).Offset(1)
'            Sheets("Tensile Ext").Select
'            Range("A21").Select                 ' this will always paste to the same cell
                                                 ' I changed that
            ' the next line pastes to A21 as per your original code
'            Cell.Offset(1, 0).Copy Destination:=Rng.Cells(1)
'            ActiveSheet.Paste
        End If

        ' consider HLOOKUP instead of the above entire IF block
'        On Error Resume Next                    ' in case not found
'        Tmp = Application.HLookup(Itm, WsTr.Range("A1:I2"), 2, False)
'        If Err.Number = 0 Then
'            WsTe.Cells(WsTe.Rows.Count, "A").End(xlUp).Offset(1).Value = Tmp
'        End If
    Next Cell

    On Error GoTo 0                             ' only needed if HLOOKUP is deployed
'    Range("A21:D21").Select                     ' don't select anything
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
        .Merge
        ' not sure what this will do. Looks faulty:-
        ' you are applying AutoFill to a range both smaller (in width)
        ' and larger (potentially - in height) than the source cell
        ' of your AutoFill, which is probably blank!
        .AutoFill Destination:=WsTe.Range(.Cells(1), .Cells(1).End(xlDown)), Type:=xlFillDefault
    End With
'    Selection.Merge
'    Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown)), Type:=xlFillDefault
End Sub

Answer 2

Итак, я немного обновил свой код, чтобы создать подпрограммы для повторяющихся частей. Ниже мой новый код. Я оставил один l oop в основном коде только потому, что в нем было форматирование для высоты строки, и я не хотел, чтобы каждая вставка равнялась go через это изменение. Это немного сократило время выполнения. Когда у меня есть большое количество образцов, это все еще занимает много времени, может быть, вы, ребята, можете увидеть, что я скучаю. Может быть, есть способ отформатировать все ячейки одинаково за один раз? Я не уверен.

''Finds data from results and brings it into datasheet
Sub Update_Data_Click()

''Sets up Variables

    Dim Job As String
    Dim Year As String
    Dim Folder As String
    Dim TestResults As String
    Dim Sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim Tst As Range
    Dim Row As Long
    Dim i As Long
    
    

Worksheets("Tensile Ext").Rows(37 & ":" & Worksheets("Tensile Ext").Rows.Count).Delete
Worksheets("Tensile Ext").Range("A21:D36").ClearContents
Worksheets("Tensile Ext").Range("N21:AG36").ClearContents

''Change year here each year

    Job = Range("S2")
    Year = 2020
    Folder = "D-MaterialsTesting"
    TestResults = "TestResults"
    
 ''Finds Job folder with from support data
    Application.ScreenUpdating = False
    Workbooks.OpenText Filename:="S:" & "\" & Folder & "\" & Year & "\" & Job & "\" & "TestResults" & ".csv", DataType:=xlDelimited, comma:=True
    With ActiveWorkbook
        .ActiveSheet.Copy After:=ThisWorkbook.Sheets(Sheets.Count)
        .Close
    End With

    Sheets("TestResults").Select
    Range("A2").Select
 If ActiveSheet.UsedRange.Rows.Count = 2 Then
    
    ''Copies Sample ID Data from TestResults Datasheet
    Call CopyResultData1("A21", "A21:D21", "Sample ID")
    ''Copies Ultimate Force from TestResults Datasheet
    Call CopyResultData1("N21", "N21:Q21", "Ultimate Force")
    ''Copies Yield Force Data from TestResults Datasheet
    Call CopyResultData1("R21", "R21:U21", "Offset Force")
    ''Copies Ultimate Stress Data from TestResults Datasheet
    Call CopyResultData1("V21", "V21:Y21", "Ultimate Stress")
    ''Copies Yield Stress Data from TestResults Datasheet
    Call CopyResultData1("Z21", "Z21:AC21", "Offset Stress")
    ''Copies Elongation Data from TestResults Datasheet
    Call CopyResultData1("AD21", "AD21:AE21", "Elongation")
    
    ''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
 ElseIf Range(Selection, Selection.End(xlDown)).Count < 20000 Then

    Sheets("TestResults").Select
    Range("A2").Select
    Row = 20 + Range(Selection, Selection.End(xlDown)).Count
    i = 21
    
''Copies Sample ID Data from TestResults Datasheet
    Sheets("Tensile Ext").Select
    Range("A21").Select
    Range(Selection, "A" & Row).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each Tst In Range("A1:L1")
        If InStr(Tst.Value, "Sample ID") > 0 Then
            Tst.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range("A21").Select
            Range(Selection, "A" & Row).Select
            ActiveSheet.Paste
        Exit For
        End If
    Next Tst
    
    Do While i <= Row
        Range("A" & i & ":" & "D" & i).Select
         With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .MergeCells = True
            .Borders.LineStyle = xlContinuous
            .RowHeight = 24
        End With
        i = i + 1
    Loop
    
    i = 21
    
''Copies Ultimate Stress Data from TestResults Datasheet
    Call CopyResultData2("N21", "N" & i & ":" & "Q" & i, "Ultimate Force", Row, i, "N", "Q")
''Copies Yield Force Data from TestResults Datasheet
    Call CopyResultData2("R21", "R" & i & ":" & "U" & i, "Offset Force", Row, i, "R", "U")
''Copies Ultimate Stress Data from TestResults Datasheet
    Call CopyResultData2("V21", "V" & i & ":" & "Y" & i, "Ultimate Stress", Row, i, "V", "Y")
''Copies Yield Stress Data from TestResults Datasheet
    Call CopyResultData2("Z21", "Z" & i & ":" & "AC" & i, "Offset Stress", Row, i, "Z", "AC")
''Copies Elongation Data from TestResults Datasheet
    Call CopyResultData2("AD21", "AD" & i & ":" & "AE" & i, "Elongation", Row, i, "AD", "AE")
    
''This deletes copied Worksheet
    Application.DisplayAlerts = False
    Sheets("TestResults").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End If

End Sub

Sub CopyResultData1(ByVal PstRng As String, ByVal FormRng As String, ByVal Rslt As String)

Worksheets("TestResults").Select
    For Each Tst In Range("A1:L1")
        DoEvents
        If InStr(Tst.Value, Rslt) > 0 Then
            Tst.Offset(1, 0).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range(PstRng).Select
            ActiveSheet.Paste
        Exit For
        End If
    Next Tst
    Range(FormRng).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
    End With
    Selection.Merge

End Sub
Sub CopyResultData2(ByVal PstRng As String, ByVal FormRng As String, ByVal Rslt As String, ByVal Row As String, ByVal i As Variant, PstCol1, PstCol2)

 Sheets("Tensile Ext").Select
    Range(PstRng).Select
    Range(Selection, PstCol1 & Row).Select
    Selection.UnMerge
    Sheets("TestResults").Select
    For Each Tst In Range("A1:L1")
        If InStr(Tst.Value, Rslt) > 0 Then
            Tst.Offset(1, 0).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Tensile Ext").Select
            Range(PstRng).Select
            Range(Selection, PstCol1 & Row).Select
            ActiveSheet.Paste
        Exit For
        End If
    Next Tst
    
    Do While i <= Row
        Range(PstCol1 & i & ":" & PstCol2 & i).Select
         With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .ReadingOrder = xlContext
            .MergeCells = True
            .Borders.LineStyle = xlContinuous
        End With
        i = i + 1
    Loop

End Sub