Bill Williamson
Board Regular
- Joined
- Oct 7, 2019
- Messages
- 124
I have a macro I run on an export sheet from another program. I am worried that if this were ever accidentally run
with the wrong window open in excel it could do some damage to any other worksheet.
I would like the code to only work with worksheets named "JobOperationsExport43" but excluding the number because it changes.
I believe I have to declare the worksheet name as a variable, and verify in an if than statement but i am not sure.
Any help would be appreciated.
Thanks,
Bill Williamson
below is the code I use.
with the wrong window open in excel it could do some damage to any other worksheet.
I would like the code to only work with worksheets named "JobOperationsExport43" but excluding the number because it changes.
I believe I have to declare the worksheet name as a variable, and verify in an if than statement but i am not sure.
Any help would be appreciated.
Thanks,
Bill Williamson
below is the code I use.
VBA Code:
Sub SitelineDataMacro()
'
' Siteline Data Macro
' Shorten Data File from Siteline
'
' Keyboard Shortcut: Ctrl+g
' Verify worksheet name or exit macro
ActiveSheet.Name = "export"
Application.ScreenUpdating = False
Columns("A:B").Select
Selection.ClearContents
Selection.Delete Shift:=xlToLeft
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Columns("C:AA").Select
Selection.Delete Shift:=xlToLeft
Columns("D:S").Select
Selection.Delete Shift:=xlToLeft
Columns("E:V").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.SmallScroll ToRight:=-3
Cells.Select
Cells.EntireColumn.AutoFit
Range("E4").Select
Columns("B").Select
Selection.Cut
Columns("D").Select
Selection.Insert Shift:=xlToRight
'Removes "J" from Job Numbers
Columns("A").Select
Selection.Replace "j", ""
Cells.Range("A1").Select
Selection.Replace "ob", "Job#"
'Renames Part Number
Columns("C").Select
Selection.Replace "item", "Part#"
'Renames Quantity
Columns("D").Select
Selection.Replace "Received", "Quantity"
'Delete any Row that Part Number ends in "C"
Dim lr As Long, i As Long
lr = Range("C" & Rows.Count).End(xlUp).Row
For i = lr To 1 Step -1
If InStr(Range("C" & i), "C") > 0 Then
Range("C" & i).EntireRow.Delete
End If
Next i
ActiveSheet.Columns("A:B").Insert Shift:=xlToRight
ActiveSheet.Name = "Export"
'Message boxes for Customer and CSO entry
Dim CSO As String, Customer As String
CSO = InputBox("CSO #")
Customer = InputBox("Customer Name")
Range("A2").Value = CSO
Range("B2").Value = Customer
Range("A1:B1").Value = Array("CSO#", "Customer")
[A2].Resize(Range("C" & Rows.Count).End(xlUp)(0).Row, 2).Value = Array(CSO, Customer)
Columns("C").Select
Selection.Cut
Columns("B").Select
Selection.Insert Shift:=xlToRight
'Centers Resizes and Aligns Data to Correct Format
Cells.Select
With Selection
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Test\Testworkbook.xlsx", FileFormat:=51
Workbooks.Open Filename:= _
"C:\Users\Billw\Desktop\QA Documents\Stainless Data Entry 120519.xlsm"
'Find the last used row in both sheets and copy and paste data below existing data.
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
'Set variables for copy and destination sheets
Set wsCopy = Workbooks("Testworkbook.xlsx").Worksheets("Export")
Set wsDest = Workbooks("Stainless Data Entry 120519.xlsm").Worksheets("Data")
' Find last used row in the copy range based on data in column A
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
' Find first blank row in the destination range based on data in column C
'Offset property moves down 1 row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row
'Copy& Paste Data
wsCopy.Range("A2:F" & lCopyLastRow).Copy
wsDest.Range("C" & lDestLastRow).PasteSpecial
'Date Stamp and column Numbering
Range("B" & lDestLastRow & ":B" & lDestLastRow + lCopyLastRow - 2).Value = Date
Range("A" & lDestLastRow & ":A" & lDestLastRow + lCopyLastRow - 2).Formula = "=r[-1]c+1"
Workbooks("Testworkbook.xlsx").Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data Transferred"
'Set Print area and print data range pasted to worksheet
ActiveWindow.RangeSelection.PrintOut
'ActiveWorkbook.Save
'Application.Quit
'Workbooks.ThisWorkbook.Close SaveChanges:=True
'Filename:= _
"C:\Users\Billw\Desktop\QA Documents\Stainless Data Entry 120519.xlsm"
End Sub