Sub Test()
Dim ws As Worksheet
Application.CopyObjectsWithCells = False
'do your copy
ActiveSheet.Copy
ActiveSheet.Unprotect
For Each ws In ActiveWorkbook.Worksheets
Application.CopyObjectsWithCells = True
ws.UsedRange.Value = ws.UsedRange.Value
Next ws
End Sub
Sub add_apostrophe()
'will add an ' in front of whats in the used range in column A
Set rng = Intersect(Range("A:F"), ActiveSheet.UsedRange)
For Each c In rng
c.Value = "'" & c
Next
End Sub
For Each ws In Sheets Application.DisplayAlerts = False If ws.Name = "A" Or "B" Or "C" Then ws.Delete End If Next
For Each ws In Sheets
Application.DisplayAlerts = False
If ws.Name = "A" Or "B" Or "C" Then
ws.Delete
End If
Next
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim MyRangeArray As Variant
Dim oPPTApp As PowerPoint.Application
Dim x As Long
MyRangeArray = _
Array( _
Sheets("All DDR").Range("A3:J11"), Sheets("All DDR").Range("A13:J21"),
Sheets("All DDR").Range("A23:J31"), _
Sheets("All DDR").Range("A33:J41"), Sheets("All DDR").Range("A43:J51"),
Sheets("All DDR").Range("A53:J61"), _
Sheets("All DDR").Range("A63:J71"), Sheets("All DDR").Range("A73:J81"),
Sheets("All DDR").Range("A83:J91"), _
Sheets("All DDR").Range("A93:J101"), Sheets("All
DDR").Range("A103:J111"), _
_
Sheets("TNR DDR").Range("A3:J11"), Sheets("TNR DDR").Range("A13:J21"),
Sheets("TNR DDR").Range("A23:J31"), _
Sheets("TNR DDR").Range("A33:J41"), Sheets("TNR DDR").Range("A43:J51"),
Sheets("TNR DDR").Range("A53:J61"), _
Sheets("TNR DDR").Range("A63:J71"), Sheets("TNR DDR").Range("A73:J81"),
Sheets("TNR DDR").Range("A83:J91"), _
Sheets("TNR DDR").Range("A93:J101"), Sheets("TNR
DDR").Range("A103:J111"), _
_
Sheets("BE2 DDR").Range("A3:J11"), Sheets("BE2 DDR").Range("A13:J21"),
Sheets("BE2 DDR").Range("A23:J31"), _
Sheets("BE2 DDR").Range("A33:J41"), Sheets("BE2 DDR").Range("A43:J51"),
Sheets("BE2 DDR").Range("A53:J61"), _
Sheets("BE2 DDR").Range("A63:J71"), Sheets("BE2 DDR").Range("A73:J81"),
Sheets("BE2 DDR").Range("A83:J91"), _
Sheets("BE2 DDR").Range("A93:J101"), Sheets("BE2
DDR").Range("A103:J111"), _
_
Sheets("FE+BE1 DDR").Range("A3:J11"), Sheets("FE+BE1
DDR").Range("A13:J21"), Sheets("FE+BE1 DDR").Range("A23:J31"), _
Sheets("FE+BE1 DDR").Range("A33:J41"), Sheets("FE+BE1
DDR").Range("A43:J51"), Sheets("FE+BE1 DDR").Range("A53:J61"), _
Sheets("FE+BE1 DDR").Range("A63:J71"), Sheets("FE+BE1
DDR").Range("A73:J81"), Sheets("FE+BE1 DDR").Range("A83:J91"), _
Sheets("FE+BE1 DDR").Range("A93:J101"), Sheets("FE+BE1
DDR").Range("A103:J111") _
)
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp =
CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Copy Range from Excel
For x = 0 To 43
Set rng = MyRangeArray(x)
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial (Link = True)
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
Next
End Sub
Sub Sample()
Dim fn As Integer
Dim MyData As String
Dim lineData As String, strData() As String, myFile As String
Dim i As Long, rng As Range
myFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")
Set rng = Range("D1")
fn = FreeFile
Open myFile For Input As #fn
i = 1
Do While Not EOF(fn)
Line Input #fn, lineData
strData = Split(lineData, "")
rng.Cells(i, 1).Resize(1, UBound(strData) + 1) = strData
i = i + 1
Loop
Close #fn
Dim counter As Long
counter = 2
For Each cell In Range("A1", Range("A1").SpecialCells(xlCellTypeLastCell)
If InStr(1, cell, "102.") > 0 Then
Cells(counter, 1) = (Mid(cell, InStr(1, cell, ".") + 1, 30))
End If
If Left(Trim(cell), 4) = "303." Then
Cells(counter, 2) = Mid(cell, InStr(1, cell, ".") + 1, InStr(1, cell, "W")  InStr(1, cell, ".")  1)
counter = counter + 1
End If
Next
End Sub
=AND(MOD(A1,1)=0,MOD(C1,1)=0,A1+C1<10,MIN(A1,C1)>=0,MAX(A1,C1)=5)
=AND(MOD(A1,1)=0,MOD(C1,1)=0,A1+C1<10,MIN(A1,C1)>=0,MAX(A1,C1)=5)
Reference  Count 
Magnabilities  1 
79907252685  1 
Mechatronics  10 
79903088794  1 
79904096168  1 
79906457350  1 
79906925828  1 
79904818173 / ASQNSH17040483  1 
79908520114  1 
79904054639 / FTNVSHS000146568  1 
79904054407  1 
79905323132  1 
79904681852  1 
Montana Fly  1 
79908133272  1 
Olympic Foundry  1 
79903047972  1 
Totals  13 
Sub PrintBasicIAP()
'Opens up the sheets in print preview. You may cancel or print from the print preview screen.
Dim ppWorksheets()
Dim count As Long
Dim ws As Worksheet
Dim dummy As String
Application.EnableEvents = False
Application.ScreenUpdating = False
UserForm1.Hide
ppWorksheets = Array("IAP Cover", "202", "203", "205", "206", "208")
count = UBound(ppWorksheets)
For Each ws In ThisWorkbook.Worksheets
If StrComp(Left(ws.Name, 3), "204", vbTextCompare) = 0 Then
count = count + 1
ReDim Preserve ppWorksheets(count)
ppWorksheets(UBound(ppWorksheets)) = ws.Name
End If
Next ws
Sheets(ppWorksheets).PrintPreview
Sheets("Print IAP").Select
Call ShowUserform1(dummy)
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
'=IF(BQ161694=TODAY()1,"use","ignore")'
'=IF(BQ161694=TODAY()1,"use","ignore")'
Sub TimeSplit2()
'
' TimeSplit2 Macro
'
'
Cells.Select
Range("E17").Activate
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A137") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:D137")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
"", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Range("E1").Select
ActiveCell.FormulaR1C1 = "Start"
Range("F1").Select
ActiveCell.FormulaR1C1 = "End"
Range("F2").Select
End Sub

7.7 (20592)  1E1 
7.1(20592)  1E1 
8.8. (20941)  1I1..... 
Sub sku()
Dim erow As Long
Dim ws As Worksheet
Dim lastrow As Long
Dim count As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
lastrow = Sheets(1).Cells(Rows.count, 1).End(xlUp).Row
lastrow1 = Sheets(3).Cells(Rows.count, 1).End(xlUp).Row
lastcolumn = Sheets(1).Cells(1, Columns.count).End(xlUp).Column
For x = 2 To lastrow
If Sheets(1).Cells(x, 1) = Sheets(2).Range("A2") Then
For y = 3 To lastcolumn
For z = 1 To lastrow1
If Sheets(1).Cells(x, y) = Sheets(3).Cells(z, 1) Then
Sheets(2).Range("J& z") = Sheets(3).Cells(z, 2)
End If
Next z
Next y
End If
Next x
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim FindString As String
Dim Rng As Range
If Target.Column = 1 Then
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("A:A") 'searches all of column A
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
MsgBox "Duplicate found"
Application.Goto Rng, True 'value found
Else
End If
End With
End If
End If
End Sub