Excel .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDe
.MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制屈服应力数据 板材（“拉伸延伸”）。选择 范围（“Z21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个YS（“A1:I1”） 如果InStr（YS.值，“偏移应力”）>0，则 Y.偏移量（1，0）。选择 选择，复制 板材（“拉伸延伸”）。选择 范围（“Z21”）。选择 活动表。粘贴 如果结束 下一个 范围（“Z21:AC21”）。选择 有选择 .HorizontalAlignment=xlCenter .垂直对齐=xl底部 .WrapText=False .方向=0 .AddIndent=False .1级别=0 .ShrinkToFit=False .ReadingOrder=xlContext .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制伸长数据 板材（“拉伸延伸”）。选择 范围（“AD21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个ELG（“A1:I1”） 如果仪表（ELG值，“伸长率”）大于0，则 标高偏移（1，0）。选择 选择，复制 板材（“拉伸延伸”）。选择 范围（“AD21”）。选择 活动表。粘贴 如果结束 下一只麋鹿 范围（“AD21:AE21”）。选择 有选择 .HorizontalAlignment=xlCenter .垂直对齐=xl底部 .WrapText=False .方向=0 .AddIndent=False .1级别=0 .ShrinkToFit=False .ReadingOrder=xlContext .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''这将删除复制的工作表 Application.DisplayAlerts=False 工作表（“测试结果”）。删除 Application.DisplayAlerts=True Application.ScreenUpdating=True ElseIf范围（Selection，Selection.End（xlDown））。然后计数<2000 ''从TestResults数据表复制样本ID数据 板材（“拉伸延伸”）。选择 范围（“A21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个样本ID（“A1:I1”） 如果InStr（SampleID.Value，“样本ID”）>0，则 样本ID偏移量（1，0）。选择 范围（选择，选择。结束（xlDown））。选择 选择，复制 板材（“拉伸延伸”）。选择 范围（“A21”）。选择 范围（选择，选择。结束（xlDown））。选择 活动表。粘贴 如果结束 下一个样本 范围（“A21:D21”）。选择 有选择 .HorizontalAlignment=xlCenter .垂直对齐=xl底部 .WrapText=False .方向=0 .AddIndent=False .1级别=0 .ShrinkToFit=False .ReadingOrder=xlContext .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制最终力数据 板材（“拉伸延伸”）。选择 范围（“N21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个UTF（“A1:I1”） 如果仪表（UTF值，“极限力”）>0，则 UTF偏移量（1，0）。选择 范围（选择，选择。结束（xlDown））。选择 选择，复制 板材（“拉伸延伸”）。选择 范围（“N21”）。选择 范围（选择，选择。结束（xlDown））。选择 活动表。粘贴 如果结束 下一个UTF 范围（“N21:Q21”）。选择 有选择 .HorizontalAlignment=xlCenter .垂直对齐=xl底部 .WrapText=False .方向=0 .AddIndent=False .1级别=0 .ShrinkToFit=False .ReadingOrder=xlContext .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制屈服力数据 板材（“拉伸延伸”）。选择 范围（“R21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个YF（“A1:I1”） 如果InStr（YF.值，“偏移力”）>0，则 YF.偏移量（1，0）。选择 范围（选择，选择。结束（xlDown））。选择 选择，复制 板材（“拉伸延伸”）。选择 范围（“R21”）。选择 范围（选择，选择。结束（xlDown））。选择 活动表。粘贴 如果结束 下一个YF 范围（“R21:U21”）。选择 有选择 .HorizontalAlignment=xlCenter .垂直对齐=xl底部 .WrapText=False .方向=0 .AddIndent=False .1级别=0 .ShrinkToFit=False .ReadingOrder=xlContext .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制极限应力数据 板材（“拉伸延伸”）。选择 范围（“V21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于Excel .MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDe,excel,vba,Excel,Vba,.MergeCells=False .Borders.LineStyle=xlContinuous 以 选择。合并 Selection.AutoFill目标：=范围（Selection，Selection.End（xlDown）），类型：=xlFillDefault ''从测试结果数据表复制屈服应力数据 板材（“拉伸延伸”）。选择 范围（“Z21”）。选择 范围（选择，选择。结束（xlDown））。选择 选择。取消合并 工作表（“测试结果”）。选择 对于范围内的每个YS（“A1:I1”） 如果I
''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
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