Sub ProForm1()
'
' ProForm1 Macro
'
'Define Worksheets
Dim pf As Worksheet
Set pf = Worksheets("ProForm")
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet1")
Dim d As Worksheet
Set d = Worksheets("Dimensions")
Dim ft As Worksheet
Set ft = Worksheets("Fitment")
'Run Concat Formula
ft.Select
Columns(7).Select
Selection.Value = Selection.FormulaR1C1
'Copy Concat Value and Paste
ft.Select
Columns(7).Select
Selection.Copy
ft.Select
Columns(9).Select
Selection.PasteSpecial Paste:=xlPasteValues
'Copy and Paste Part Number, MAP, UPC headers
pf.Select
Range("C1:E1").Select
Selection.Copy
sh1.Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
sh1.Columns("A").ColumnWidth = 11.57
'Cut and Paste Short Description
pf.Select
Range("B2").Select
Selection.Cut
sh1.Select
Range("A5").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Selection.Font.Size = 14
'Copy and Paste Part Number, MAP, UPC Values
pf.Select
Range("C2:E2").Select
Selection.Copy
sh1.Select
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Copy and Projected Availability Header
pf.Select
Range("F1").Select
Selection.Copy
sh1.Select
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
'Copy and Paste Projected Availability then Format to a Date
pf.Select
Range("F2").Select
Selection.Copy
sh1.Select
Range("A11").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Value = Selection.Value
'Copy and Paste Box Dimension Header
pf.Select
Range("G1").Select
Selection.Copy
sh1.Select
Range("A13").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
'Copy and Paste Length Width Height Headers
pf.Select
Range("H1:K1").Select
Selection.Copy
sh1.Select
Range("A14").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Check to see if Box or Retail Dims exist
'Copy Box dims if exist otherwise Retail Dims
Dim dimension As String
dimension = d.Range("B2").Value
If dimension = "0" Or dimension = "0.000" Then
d.Select
Range("E2:G2").Select
Selection.Copy
sh1.Select
Range("B14").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Else
d.Select
Range("B2:D2").Select
Selection.Copy
sh1.Select
Range("B14").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End If
'Copy and Paste Weight Value
d.Select
Range("H2").Select
Selection.Copy
sh1.Select
Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Copy and Paste Installation Header
pf.Select
Range("L1").Select
Selection.Copy
sh1.Select
Range("A19").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
'Copy and Paste Time, Drilling, Visiblity, Codes Headers
pf.Select
Range("M1:P1").Select
Selection.Copy
sh1.Select
Range("A20").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Copy and Paste Time, Drilling, Visiblity, Codes Values
pf.Select
Range("M2:P2").Select
Selection.Copy
sh1.Select
Range("B20").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Copy and Paste Description Header
pf.Select
Range("R1").Select
Selection.Copy
sh1.Select
Range("A25").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
'Copy and Paste Bullets
pf.Select
Range("S2:T2").Select
Selection.Copy
sh1.Select
Range("A26").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Copy and Vehicle Application Header
pf.Select
Range("U1").Select
Selection.Copy
sh1.Select
Range("A29").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
'Insert Pic
Dim profile As String
On Error GoTo 0
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png"
.ButtonName = "Select"
.AllowMultiSelect = False
.Title = "Choose Photo"
.InitialView = msoFileDialogViewDetails
.Show
End With
sh1.Range("F6").Select
sh1.Shapes.AddPicture Filename:=fd.SelectedItems(1), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoCTrue, _
Left:=ActiveSheet.Range("F6").Left, _
Top:=ActiveSheet.Range("F6").Top, _
Width:=238, _
Height:=238
'copy app data
Dim UsdRws As Long
With Sheets("fitment")
UsdRws = .Range("G" & Rows.Count).End(xlUp).Row
.Range("I2:I" & UsdRws).Value = Range("G2:G" & UsdRws).Value
Sheets("Sheet1").Range("A30").Resize(UsdRws - 1).Value = .Range("I2:I" & UsdRws).Value
End With
'Delete Worksheets
Worksheets("ProForm").Delete
Worksheets("Dimensions").Delete
'Rename Sheet 1
sh1.Name = "Pro Form"
End Sub