Pasting as link errors out - excel

I wrote a code with a loop that copies a special cell in a source workbook and then opens another workbook and pastes a copied number to a special cell, and after seven times I get this error:
this is my code:
ActiveSheet.Paste Link:=True
I don't understand why it happens.
Sub Shadow()
ActiveSheet.Range("$A$1:$I$9627").AutoFilter Field:=4, Criteria1:="basic"
' Copy filtered worksheet
Number = Application.WorksheetFunction.Subtotal(3, Range("A1:A500000"))
ActiveSheet.Range("$A$1:$I$9627").SpecialCells(xlCellTypeVisible).Copy
' Addition of new sheet
Sheets.Add
ActiveSheet.Paste
' Calculating number of rows
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
' A loop for copying row by row number and date then opening shadowgraph for pasting copied data
Dim i1 As Integer
For i1 = 2 To finalrow
ActiveSheet.Cells(i1, 1).Copy
Workbooks.Open Filename:="E:\Attachment\PCI\Clutch disc\FLEXIBALE (RO)\Shadowgraph.xlsm"
Windows("Shadowgraph.xlsm").Activate
Range("AW5").Select
ActiveSheet.Paste Link:=True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Windows("ball99.xlsm").Activate
' Representing relative name for saving documents
Dim Name1 As String
Name1 = ActiveSheet.Cells(i1, 2) & "Shadowgraph"
ActiveSheet.Cells(i1, 2).Copy
Windows("Shadowgraph.xlsm").Activate
Range("E32").Select
ActiveSheet.Paste Link:=True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Set work directory
ChDir "E:\Attachment\PCI\Clutch disc\FLEXIBALE (RO)"
' Set saving address
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"E:\Attachment\PCI\Clutch disc\FLEXIBALE (RO)\" & _
Name1, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Windows("Shadowgraph.xlsm").Activate
' Closing opened datasheets
Windows("Shadowgraph.xlsm").Close (False)
Next i1
Windows("ball99.xlsm").Activate
' Closing every sheets except main workbook 01
Dim ws1 As Worksheet
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "01" Then ws1.Visible = xlSheetHidden
Next ws1
' Clearing all fiters
ActiveSheet.ShowAllData
End Sub

Related

Row counter for looping macro not updating

I've been working on a Macro in Excel that should go through every sheet in the workbook, count the number of rows in a given sheet, and then format those rows. The other day I was able to run it successfully, with the macro formatting the entire workbook, however the next time I attempted to run it, the value for the number of rows did not update, and it only formatted the rest of the sheets up to the number of rows in the first sheet (i.e. if the first sheet is 22 rows long, it will format every sheet, but only the first 22 rows of that sheet, leaving the rest unformatted). I have attempted trying some changes to the macro, but cannot figure out how to resolve the issue so that the row counter resets for each sheet it loops through. Any help in trying to get this macro working is appreciated.
The macro as I currently have it written is as follows:
Sub Formatting()
'
' Formatting Macro
'
' Keyboard Shortcut: Ctrl+Shift+F
'
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("$A$1:$X$" & lr).Select
With Selection.Font
.Name = "Century"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("G:G").Select
Selection.ColumnWidth = 75
With Selection
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.Select
Cells.EntireRow.AutoFit
Range("A1").Select
End With
Next ws
End Sub

For the sake of making your formatting subroutine more specific, I have pulled out the formatting itself to private subroutines, so you can see what you're working with. You format a designated range and its font, then separately format column G; both of which add bulk to your base functions and are repeated.
Beyond that, I have removed the Select items, aside from the "A1" select to reset position on each sheet.
Imparting my comments on your code (untested):
Sub Formatting()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
Dim lr as Long: lr = .Cells(.Rows.Count, "A").End(xlUp).Row
DesignatedRangeFormatting .Range("$A$1:$X$" & lr)
ColumnGFormatting .Columns("G")
.Cells.EntireRow.AutoFit
.Select
.Range("A1").Select
End With
Next ws
End Sub
Private Sub DesignatedRangeFormatting(rng as Range)
With rng.Font
.Name = "Century"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Private Sub ColumnGFormatting(rng as Range)
With rng
.ColumnWidth = 75
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Edit1: Added .Select before .Range("A1").Select to ensure the current sheet is selected, which resolves the RTE1004.

Split data into multiple sheets based on column

#Modifying Question for better understanding and how do i want the result is.
Wizhi answer almost matched for my question !! But need some more
changes in his answer because which code is not working for me !! And
no need to work based on GCN Date as he answered. The split work
done based on Destination Pincode .
Please help someone help me to Macro Code for Split data into multiple sheet within an excel workbook based on a table format. Below is the explanation of how i have done as per my knowledge and what is my expectation is !!
"Here is the workbooks what i have Done"
Please download the Macro_Folder and Unzip it in you "C" Drive.
Open Macro Workbook and Press Button to run macro.
If it asked for updating formulas as shown in below picture please select "Don't Update" to continue macro.
My Macro workbook view :
I Have done button option to Run the split macro in separate excel workbook.
Where the files Located
When self open and run Macro from Macro Workbook it automatically opens my XD MIS Report and start formatting and split the date into multiple sheets.
View of XD MIS is "Master Data" which is having overall raw data.
Here is the view after self Run Macro fro split Master data.
Code that i Used For Split Data into Multiple Sheet:
Sub Spli_Data()
Dim wb As Workbook
Dim myfilename As String
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
myfilename = "C:\Macro\XD MIS Report.xlsx"
Set wb = Workbooks.Open(myfilename)
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
Columns("B:F").Select
Range("B2").Activate
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Range("H2").Activate
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Range("K2").Activate
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Range("D2").Activate
Selection.Cut
Selection.End(xlToRight).Select
Columns("K:K").Select
Range("K2").Activate
Selection.Insert Shift:=xlToRight
Selection.End(xlUp).Select
Range("K1").Select
ActiveCell.FormulaR1C1 = "Remarks"
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H1").Select
ActiveCell.FormulaR1C1 = "Packing Type"
Range("H1").Select
Selection.End(xlToLeft).Select
Cells.Select
Selection.FormatConditions.Delete
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-1]C[6]:RC[6],RC[6])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R1C7:RC[6],RC[6])"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Columns("A:A").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Range("A1:L3100").Select
Range("A2").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri Light"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("A2").Select
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Result Of Split Data What i have right now:
Destination 1
Destination 2
Now Let's Clear About My Requirement:
I have done macro for format and Split Data into multiple Sheet,But this the not exact format result which i'm looking for.
The split should be done in same method but for result format should be like below formats based on macro code.
The split data should be in Multiple sheets of within an Excel Workbook . Not split to multiple workbooks !!
Write a macro for split Data in this format for all Destination Pincode:
This how i'm expecting final result through macro code
Expected Format of #Destination 1 Sample After Split done
#Destination 1 Sample
This is an examples of what i'm looking for. The same have to done
for all destination which is in Master Data
Hope !! now my question is clear for better understanding and easy to answer.

Updated code:
#Mark Balhoff, Thanks for your valuable input, I always like to learn and get feedback to improve myself :). I have used your input in the code and also extended it a bit.
This code is using dictionary so you need to activate "Microsoft Scripting Runtime"
"Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
User process to split Master Data:
I assume that the user will split this data in the picture:
Pressing the button, it will choose column 7.
(My opinion is that this part with InputBox etc... is unnecessary as you always want to filter by column 7 regardless, so I feel it confused the end user)
Is quite unclear from what "raw data" you start with as new pictures/data have appeared in the updated question. I have assumed that the data that we should split looks like this, as it was stated first
Output of the first unique Destination Pincode:
Output of the second unique Destination Pincode:
Code:
Option Explicit
Sub Split()
Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet
Dim DestPincode As Range
Dim DestPincodeCol As Long
Dim vcol As Long
Dim vcol_value As String
Dim vcol_name As String
Dim vcol_prompt As String
Dim i As Integer
Dim DestPincode_ws_new As Range
Dim DestPincodeCol_ws_new As Long
Dim DestPincodeRow_ws_new As Long
Application.ScreenUpdating = False
'##### SETTINGS #####
Set ws = ActiveWorkbook.Worksheets("Master_Data") 'Set master data sheet
Set DestPincode = ws.Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
'####################
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Find last column in Master Data
DestPincodeCol = DestPincode.Column 'Get column number for Destination Pincode
lr = ws.Cells(ws.Rows.Count, DestPincodeCol).End(xlUp).Row 'Get last row
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
'##### Filter based on InputBox #####
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="7", Type:=1)
If vcol <> 7 Then Exit Sub
'##### Get all the uniqe "Destination Pincodes" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim DestPincodeData()
Dim UniqueDestPincodeData As Object
Dim DestPinRow As Long
Set UniqueDestPincodeData = CreateObject("Scripting.Dictionary")
DestPincodeData = Application.Transpose(ws.Range(ws.Cells(1, DestPincodeCol), ws.Cells(ws.Cells(Rows.Count, DestPincodeCol).End(xlUp).Row, DestPincodeCol))) 'Get all the Destination Pincode values
For DestPinRow = 2 To UBound(DestPincodeData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
UniqueDestPincodeData(DestPincodeData(DestPinRow)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Destination Pincodes and add to seperate workbooks #####
Dim new_wb As Workbook
Set new_wb = Application.Workbooks.Add 'Add new workbook
'Set new_wb = ActiveWorkbook
Dim DestPincodeName As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Filter range 'Set filter range
For Each DestPincodeName In UniqueDestPincodeData.Keys 'Filter through all the unique names in dictionary "UniqueDestPincodeData"
'Debug.Print "Destination Pincode: " & DestPincodeName 'Print current unique Destination Pincode name
'Filter the data based on "Destination Pincode" and Column from InputBox
With MyRangeFilter
.AutoFilter Field:=DestPincodeCol, Criteria1:=DestPincodeName, Operator:=xlFilterValues 'Filter on Destination Pincode
End With
'##### Create new workbook for the filtered data #####
'To add to new worksheet:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = DestPincodeName
Set ws_new = new_wb.Worksheets(DestPincodeName)
'##### Create template in the new workbook #####
'Building template output, row by row
ws_new.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("*******", "TRIP NO", "TRIP DATE/TIME", "TRUCKTYPE (OWN/ATT/ADHOC)", "SEAL #", "SUPERVISOR NAME", "REMARK"))
ws_new.Range("H2:H6").Value = WorksheetFunction.Transpose( _
Array("VEHICLE NO", "VEHICLE CAPACITY", "DRIVER NAME", "DRIVER NO", "VENDOR NAME"))
Dim Top_Area_Cell_Format As Range
Set Top_Area_Cell_Format = ws_new.Range("A1:L1,A7:L7,A2:D2,E2:G2,H2:I2,J2:L2," _
& "A3:D3,E3:G3,H3:I3,J3:L3,A4:D4,E4:G4,H4:I4," _
& "J4:L4,A5:D5,E5:G5,H5:I5,J5:L5,A6:D6,E6:G6,H6:I6,J6:L6")
Application.DisplayAlerts = False
Top_Area_Cell_Format.Merge 'Merge cells
Top_Area_Cell_Format.HorizontalAlignment = xlLeft 'Make title in center
Top_Area_Cell_Format.Borders.LineStyle = xlContinuous 'Add border lines
Top_Area_Cell_Format.Font.Bold = True 'Add Bold text
ws_new.Range("A1:L1").HorizontalAlignment = xlCenter 'Make title in center
Application.DisplayAlerts = True
'##### Paste filtered data from Master_Data sheet #####
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter 'Make text in center
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).EntireRow.Copy 'Copy entire row from filtered data
ws_new.Cells(8, "A").PasteSpecial xlPasteAll 'Paste all values including formats
Set DestPincode_ws_new = ws_new.Range(ws_new.Cells(8, 1), ws_new.Cells(1, ws_new.Cells(8, ws_new.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
DestPincodeCol_ws_new = DestPincode_ws_new.Column
DestPincodeRow_ws_new = ws_new.Cells(ws_new.Rows.Count, DestPincodeCol_ws_new).End(xlUp).Row
'Add total
ws_new.Cells(DestPincodeRow_ws_new + 1, "A").Value = "TOTAL"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Merge 'Merge cells
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).HorizontalAlignment = xlCenter 'Make text in center
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Font.Bold = True 'Add Bold text
'Add total values
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "I"), ws_new.Cells(DestPincodeRow_ws_new + 1, "I")).Formula = "=SUM(I9:I" & DestPincodeRow_ws_new & ")" 'Add sum for "No. of cartons"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "J"), ws_new.Cells(DestPincodeRow_ws_new + 1, "J")).Formula = "=SUM(J9:J" & DestPincodeRow_ws_new & ")" 'Add sum for "Actual weights"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Font.Bold = True 'Add Bold text
'##### Add sign boxes #####
Dim Bottom_Area_Cell_Text_Rng As String
Dim Bottom_Area_Cell_Format As String
Dim Bottom_Area_Cell_Format_rng As Range
Bottom_Area_Cell_Text_Rng = "B" & DestPincodeRow_ws_new + 2 & ":H" & DestPincodeRow_ws_new + 2
ws_new.Range(Bottom_Area_Cell_Text_Rng).Value = Array("Driver Signature", "", "Incharge Signature", "", "Security Signature", "", "REMARK")
Bottom_Area_Cell_Format = "A" & DestPincodeRow_ws_new + 2 & ":A" & DestPincodeRow_ws_new + 4 & "," _
& "B" & DestPincodeRow_ws_new + 2 & ":C" & DestPincodeRow_ws_new + 4 & "," _
& "D" & DestPincodeRow_ws_new + 2 & ":E" & DestPincodeRow_ws_new + 4 & "," _
& "F" & DestPincodeRow_ws_new + 2 & ":G" & DestPincodeRow_ws_new + 4 & "," _
& "H" & DestPincodeRow_ws_new + 2 & ":L" & DestPincodeRow_ws_new + 4
Set Bottom_Area_Cell_Format_rng = ws_new.Range(Bottom_Area_Cell_Format)
Application.DisplayAlerts = False
Bottom_Area_Cell_Format_rng.Merge 'Merge cells
Bottom_Area_Cell_Format_rng.HorizontalAlignment = xlLeft 'Make title in center
Bottom_Area_Cell_Format_rng.Borders.LineStyle = xlContinuous 'Add border lines
Bottom_Area_Cell_Format_rng.VerticalAlignment = xlTop 'Alignment of text
Bottom_Area_Cell_Format_rng.Font.Bold = True 'Add Bold text
Application.DisplayAlerts = True
'Adjust Column width
ws_new.Columns("A:L").Select
Selection.EntireColumn.AutoFit
Set ws_new = Nothing 'Reset worksheet value
Next
Application.DisplayAlerts = False
new_wb.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheet1.ShowAllData 'remove filter
On Error GoTo 0
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Link to workbook:
https://www.dropbox.com/s/86wlv99y6wylpn8/split%20data.xlsm?dl=0

I'm not sure If I've understand properly, but it looks like you want to split your data depending on the value of PINCODE column.
Besides, your question is too broad right now, you should focus more.
So, as example, I understand you would select all rows containing PINCODE=PUZHAL, and copy all of them into a different workbook.
And you want this for each unique PINCODE.
I made a fake dataset coloring rows, and I split the data into new workbooks. You'll need to adapt this to paste the data into existing workbooks (or new worksheets of same workbook, whatever)
My data is like this:
My code:
Sub TEST()
Application.ScreenUpdating = False
Dim MyDict As Object
Dim i As Long
Dim MyKey As Variant
Dim LR As Long
Dim WB As Workbook
Dim MyRows As Variant
LR = Range("G" & Rows.Count).End(xlUp).Row
Set MyDict = CreateObject("Scripting.Dictionary")
For i = 2 To LR Step 1
If MyDict.Exists(Range("G" & i).Value) = False Then
'we create the PINCODE in Dictionary and assign row number
MyDict.Add Range("G" & i).Value, i
Else
'PINCODE already in Dictionary, we add the new row number
MyDict(Range("G" & i).Value) = MyDict(Range("G" & i).Value) & "|" & i
End If
Next i
'now Dictionary holds all pincodes and all row numbers for each pincode.
'we create a workbook for each PINCODE, but you can adapt this to open a exact workbook depending on PINCODE
'I'm copying the rows starting at row 1, but you can adapt this to your model for sure
For Each MyKey In MyDict.Keys
Set WB = Application.Workbooks.Add
LR = 1 'change this to starting row
MyRows = Split(MyDict(MyKey), "|") 'we create array of rows numbers
For i = LBound(MyRows) To UBound(MyRows) Step 1
'we copy range A:L from that row into destiny workbook
ThisWorkbook.ActiveSheet.Range("A" & MyRows(i) & ":L" & MyRows(i)).Copy WB.ActiveSheet.Range("A" & LR & ":L" & LR)
LR = LR + 1 'we increase LR so next data will be pasted into next row
Next i
Erase MyRows
Set WB = Nothing
DoEvents
Next MyKey
MyDict.RemoveAll
Set MyDict = Nothing
Application.ScreenUpdating = True
End Sub
And this is how i get all my data splitted into different files depending on PINCODE.

I suggest You create a Pivot Table.
By that Pivot table you create a code to extract data on a pivotable base on a list and transfer that to the formatted workbook you created and make a loop until the last Destination Pincode. I also use Excel VBA Form to Trigger this. I can make you one if you post your Excel here.

I've created a macro that transfers the selected value from the dropdown list to the sheet with the same name as the value. I recommend that you review it.
Source : Split data into multiple sheets

pivot table creation on different sheets fails on second sheet

I am new in VBA programming and this is one my first codes i am writing.
Purpose of code: I'd like to take data on Invoices sheet and take it apart to different sheets based on the last column. Then on each sheet create a pivot table for the data.
The code is quite long - i am sure there are quite a lot of unnecessary steps in it but it is 90% ok.
The frist sheet is created perfectly. The first pivot is also created. Then the second sheet is also created.
Problem: The macro runs on an error when it tries to create the pivot table for the second sheet.
Error message: Run-time error'5': Invalid Procedure call or argument
Does anyone have an idea why my macro fails on the second sheet? Thank You for your help!
Pleaase see the code below. The problem occurs after the comment of creating a pivot table
Sub copypaste()
Application.ScreenUpdating = False
'Declarations
Dim ws As Worksheet
Dim wb As Workbook
Dim cell As Range
Dim rng As Range
Dim rng1 As Range
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim LastRow As Long
Dim LastRow2 As Long
Dim Counter As Integer
Set wb = ActiveWorkbook
Set ws2 = wb.Sheets("Invoices")
Counter = 0
Debug.Print Counter
'get the number of rows in the invoices sheet
LastRow = ws2.Range("A1", ws2.Range("A1").End(xlDown)).Rows.Count
'plus invoice type and sum column creation
ws2.Select
Columns(6).Select
Range("F:F").Insert
Cells(1, 6) = "Invoice type"
Range("F2:F" & LastRow).Formula = "=LEFT(RC[1],4)"
Selection.Columns.AutoFit
Columns(19).Select
Range("S:S").Insert
Cells(1, 19) = "Sum"
Range("S2:S" & LastRow).Formula = "=SUM(RC[-8]:RC[-1])"
Selection.Style = "Comma"
Selection.NumberFormat = _
"_-* #,##0.0 _F_t_-;-* #,##0.0 _F_t_-;_-* ""-""?? _F_t_-;_-#_-"
Selection.NumberFormat = _
"_-* #,##0 _F_t_-;-* #,##0 _F_t_-;_-* ""-""?? _F_t_-;_-#_-"
Selection.Columns.AutoFit
'sorbarendezés debtor name és invoice no. szerint
ws2.Sort.SortFields.Clear
Range("A1:R" & LastRow).Sort Key1:=Range("E1"), Header:=xlYes, Key2:=Range("G1")
'list creation as a basis for filtering and taking apart the data
wb.Activate
ws2.Select
Range("A1").Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Set ws3 = Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:= _
xlYes
Range("A2").Select
Set rng1 = Range(Selection, Selection.End(xlDown))
ws3.Select
ws3.Name = "kódolás"
Set ws = wb.Sheets("kódolás")
wb.Activate
ws.Select
'go through the earlier created list and take apart the data related to each item of the list to separate sheets
For Each cell In rng1
Counter = Counter + 1
Debug.Print Counter
'filtered data copy
ws2.Select
Range("A1").Select
ws2.Range("$A$1:$W$198162").AutoFilter Field:=20, Criteria1:=cell
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'new sheet creation
With wb
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
'filtered data paste
ActiveSheet.Paste
ActiveCell.Rows("1:1").EntireRow.Select
Application.CutCopyMode = False
'go back to A1
Range("A1").Select
'Creation of pivot table
LastRow2 = ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlDown)).Rows.Count
ActiveCell.Range("A1:T" & LastRow2).Select
Debug.Print Counter
Debug.Print LastRow2
Debug.Print ActiveSheet.Name & "!" & "R1C1:R" & LastRow2 & "C19"
Debug.Print ActiveSheet.Name & "!" & "R1C23"
Debug.Print "PivotTable" & Counter
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
ActiveSheet.Name & "!" & "R1C1:R" & LastRow2 & "C19", Version:=6).CreatePivotTable TableDestination:= _
ActiveSheet.Name & "!" & "R1C23", TableName:="PivotTable" & Counter, DefaultVersion:=6
ActiveSheet.Select
Cells(1, 27).Select
With ActiveSheet.PivotTables("PivotTable" & Counter)
.ColumnGrand = True
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = True
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
End With
With ActiveSheet.PivotTables("PivotTable" & Counter).PivotCache
.RefreshOnFileOpen = False
.MissingItemsLimit = xlMissingItemsDefault
End With
ActiveSheet.PivotTables("PivotTable" & Counter).RepeatAllLabels xlRepeatLabels
With ActiveSheet.PivotTables("PivotTable" & Counter).PivotFields("Debtor name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable" & Counter).PivotFields("invoice type")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable" & Counter).AddDataField ActiveSheet.PivotTables( _
"PivotTable" & Counter).PivotFields("SUM"), "Sum of SUM", xlSum
'take out filter and go back to A1
ws2.Select
Application.CutCopyMode = False
Range("A1").Select
ws2.AutoFilter.Sort.SortFields.Clear
ActiveSheet.ShowAllData
Next cell
End Sub

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

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

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.
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.
Setting up another sub-routine will be exactly what you need to learn. No benefit for you in my doing it.
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

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

Paste same hyperlink to all sheets

I have a hyperlink on cell B1 of Sheet1. I would like to copy this exact hyperlink to cell B1 of all sheets in my workbook.
I tried copying the link, selecting all sheets and pasting, but this is not working for some reason. I also have over 50 sheets.
Update: Here's what I tried. It pastes the 'hyperlink' on all sheets in the workbook, but the hyperlink does not work for some reason.
Sub ReturnToSheet1()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Sheet1" Then
ws.Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Select
ActiveCell.FormulaR1C1 = "return to sheet1"
Rows("2:2").Select
Selection.RowHeight = 7.5
Range("B1").Select
ActiveCell.FormulaR1C1 = "return to sheet1"
Range("B1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"Sheet1!A1", TextToDisplay:="return to sheet1"
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ThemeColor = xlThemeColorHyperlink
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Font.Size = 11
Range("A3").Select
End If
Next ws
End Sub
Thanks.

I think you are making this more complicated than it needs to be:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
ws.Hyperlinks.Add _
Anchor:=ws.Range("B1"), _
Address:="", _
SubAddress:="Sheet1!A1", _
TextToDisplay:="return to sheet1"
End If
Next ws
Should be enough to do the job

Resources