TechQA.

I need someone's help to consolidate my vba code for a spreadsheet at work

72 views Asked by At

so I've been writing a code at my work to take a .csv file and pull data from it into datasheets that already have specified columns. I've never taken any kind of vba courses or anything, it's all just what I've found from forums modpodged together. Currently, it works but occasionally it breaks and crashes excel. From what I've found it looks like I need to consolidate it so I'm posting it here to see if there's someone with more knowledge who could help me do that. It was very complicated. Some of the issues I had was copying from an unmerged cell to merged cell, using a single cell to change the file path that is opening the file as a new datasheet, and using InStr to search for the correct column of cells to pull the data from. Also, sometimes there is only one dataset, in those cases I needed to be able to pull that data but using xldown was selecting all cells, so I created an if statement. See the code below.

''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
excel vba
Original Q&A
2

There are 2 answers

0
Variatus On

Your code is far too voluminous to lend itself to q quick review. You earned kudos for being self-taught but, well, not quite enough when considering the volume of your code.

To avoid such comments in the future, please learn to split your code into a Main of perhaps 20 or 30 lines which calls subs and functions, each of them not longer than 15 to 20 lines as a rule of thumb.

So, I started reviewing your code and advised you "don't select or activate anything". If you heed this advice your code will shrink by about half. Then I found a huge block of code which is repetitive. For that I created a sub-routine which is then called six times with different parameters. This is where you learn to handle repetitions.

After that I encountered an ElseIf that I hadn't found before. I added a comment at the If to the effect that the IF block was too large. I was right in that. Then I saw what appeared to be another series of repetitions which caused me to draw a balance.

  1. The changes I made are far too significant to have been accomplished without error. My code needs testing which I can't do due to lack of data.
  2. Setting up another sub-routine will be exactly what you need to learn. No benefit for you in my doing it.
  3. Nobody is better suited to resolve the ElseIf than yourself. This project needs to return to your care. Here it is - as it is. But one more note before I go: You can "recycle" variables of the same type. For example, your ranges UTF and UTS do not seem to need to keep their originally assigned values. So, one variable can probably do the job of them both, one job after the other. Once you don't need the value anymore the variable can be re-assigned to another use.

Sorry, I didn't manage to get all the code between code tags. The system wouldn't do it. Plese just copy everything below this paragraph and sort the lines in your VB Editor.

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
0
Aaron Brockmeyer On

So I've updated my code quite a bit to make subroutines for the repetitive portions. Below is my new code. I left one loop in the main code only because it had the formatting for the rowheight and I didn't want every single paste to go through that change. It shortened the runtime a bit. When I have a large amount of samples it still takes a long time, maybe you guys can see what I'm missing. Maybe there's a way to format all the cells the same way at one time? I'm not sure.

''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

Related Questions in EXCEL

Related Questions in VBA

Popular Questions

Popular Tags

javascript python java c# php android html jquery c++ css ios sql mysql r reactjs node.js arrays c asp.net json python-3.x ruby-on-rails .net sql-server swift django angular objective-c pandas excel

Trending Questions