Bill Williamson
Board Regular
- Joined
- Oct 7, 2019
- Messages
- 124
Have a macro that was working on older laptop. Had printed copy of said macro which I used to create a new macro on new computer.
Looked up and down this code but cant find any typos that would explain the error. I am currently running a newer version of excel, Could that be causing error?
I believe it may be how I am declaring variables, but it is the same as before so I am lost.
Any Help would be greatly appreciated.
I have ************ the rows that are highlighted red in my macro.
Looked up and down this code but cant find any typos that would explain the error. I am currently running a newer version of excel, Could that be causing error?
I believe it may be how I am declaring variables, but it is the same as before so I am lost.
Any Help would be greatly appreciated.
I have ************ the rows that are highlighted red in my macro.
VBA Code:
Sub SytelineDataTransfer()
' Keyboard Shortcut: Ctrl=+g
' Imports sorts data from Syteline parts reports
' Saves them into Quality tracking in excel
'
'
'
' Verify worksheet name before running, if incorrect exit macro.
If Not ActiveSheet.Name Like "JobOperationsExport*" Then Exit Sub
' Rename Worksheet
ActiveSheet.Name = "Export"
' Turns off Screen Updating for faster operation
Application.ScreenUpdating = False
' Seperates only required data, Sorts and Filters it, Puts everything into proper columns.
Columns("A:B").Select
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 letter J from Job Numbers
Columns("A").Select
Selection.Replace "j", ""
Cells.Range("A1").Select
Selection.Replace "ob", "Job#"
' Renames Item number to Part#
Columns("C").Select
Selection.Replace "item", "Part#"
' Renames Received to Quantity
Columns("D").Select
Selection.Replace "Recieved", "Quantity"
' Deletes all Carbon Steel Parts
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 Box's for Customer and CSO#
' Insert input Data into proper Columns
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
' Turns Off Alert Display
' Opens Quality Stainless document
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Test\Testworkbook.xlsx", FileFormat:=51
' Temporarily Changed to Test Program *****************************************
Workbooks.Open Filename:= _
"C:\Users\Billw\Desktop\QA Documents\Stainless Data Entry 120519 copy for code work.xlsm"
' Workbooks.Open Filename:= _
' "C:\Users\Billw\Desktop\QA Documents\Stainless Data Entry 120519.xlsm"
' Finds last used row in both sheets. Copies and pastes data below existing data.
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim 1DestLastRow As Long ' ************************************************************************************************************ RED
' Set Variables for Copy and Destination Sheets
Set wsCopy = Workbooks("Testworkbook.xlsx").Worksheets("Export")
' Modified for code work
Set wsDest = Workbooks("Stainless Data Entry 120519 copy for code work.xlsm").Worksheets("Data")
' Finds Last Used Row in the copy range based on data in Column A
1 CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
' Finds first blank row in the destination range based on Data in Column C
' Offset Property moves down 1 row
1DestLastRow = wsDest.Cells(wsDest.Rows.Count,"C").End(xlUp).Offest(1).Row '************************************************************************************ RED
' Copy and Paste Data
wsCopy.Range("A2:F" & 1CopyLastRow).Copy ' *****************************************************************************RED
wsDest.Range("C" & 1DestLastRow).PasteSpecial ' *****************************************************************************RED
' Date Stamp and Column Numbering
Range("B" & 1DestLastRow & ":B" & 1DestLastRow = 1CopyLastRow -2).Value = Date ' *****************************************************************************RED
Range("A" & 1DestLastRow & ":A" & 1DestLastRow = 1CopyLastRow -2).Formula = "=r[-1]c+1" ' *****************************************************************************RED
Workbooks("Testworkbook.xlsx").Close = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data Printed and Transferred"
' Set Print Area
ActiveWindow.RangeSelection.PrintOut
' Future Modification Code, Currently Commented Out.
' ActiveWorkbook.Save
' Application.Quit
' Workbooks.ThisWorkbook.Close SaveChanges: = True
' Filename:= _
"C:\Users\Billw\Desktop\QA Documents\Stainless Data Entry 120519.xlsm"
End Sub