Run-time error ‘1004’: Method ‘Name’ of object ‘_Worksheet’ failed - excel

I have inherited a file to perform a task. Whenever I run the "Process" button I get this error:
Run-time error ‘1004’: Method ‘Name’ of object ‘_Worksheet’ failed
Pressing the Process button should do the following:
Create new workbooks with a set filename
Filter data from the Data sheet
Copy filtered data in the created workbooks, separate sheets (renamed according to filters)
I have marked the code accordingly with: 'THIS IS THE LINE THE DEBUG POINTS OUT
Additional information, this code runs perfectly in a windows machine. I encounter this issue when using Mac.
I am very, very new to VBA, any help and guidance are appreciated.
Sub Process()
Run "Openfiles"
Dim x As Long, y As Long, teamtrgt As String, filetrgt As String, Celltrgt As String
Dim cellrange As Long, OMtrgt As String, ws As Worksheet
Windows("Macro file - extract and harvest v2.xlsm").Activate
Sheets("Macro Sheet").Select
x = 1
y = 0
cellrange = Range("a16").Value
Do Until x = Range("c1").Value
Range("D" & (x + 1)).Select
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
teamtrgt = Range("G2").Value
OMtrgt = Range("h2").Value
filetrgt = Range("i2").Value
On Error GoTo Sheetadd
Windows(filetrgt & ".xlsx").Activate
Sheets(teamtrgt).Select
GoTo SheetExisting
Sheetadd:
With ActiveWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = teamtrgt 'THIS IS THE LINE THE DEBUG POINTS OUT
End With
Windows("Macro file - extract and harvest v2.xlsm").Activate
Sheets("Data").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Windows(filetrgt & ".xlsx").Activate
ActiveSheet.Paste
Resume Next
SheetExisting:
Windows("Macro file - extract and harvest v2.xlsm").Activate
Sheets("Macro Sheet").Select
Celltrgt = Range("j2").Value
Sheets("Data").Select
Cells.Select
Range("D1").Activate
ActiveSheet.Range("$A$1:$P$" & cellrange).AutoFilter Field:=14, Criteria1:=teamtrgt
Range("A2:P" & cellrange).Select
' Range(Selection, ActiveCell.SpecialCells(xlVisible)).Select
Selection.Copy
Windows(filetrgt & ".xlsx").Activate
Sheets(teamtrgt).Select
Range("A" & Celltrgt).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Windows("Macro file - extract and harvest v2.xlsm").Activate
Sheets("Data").Select
ActiveSheet.ShowAllData
Sheets("Macro Sheet").Select
x = x + 1
Loop
End Sub

Related

Data Extraction from multiple Excel files and paste Using transpose and Link (VBA)

Im trying to Extract data from multiple Ranges in multiple Excel files, then transpose the copied data preserving the Link option. So under : Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True I added the following code : ActiveSheet.Paste Link:=True
But using this code the macro doesn't correctly link the data. Thank you !
This is the code Im using :
Sub ImportData()
Dim FileNames As Variant
Dim i As Integer
Dim j As Integer
'Application.ScreenUpdating = False
Range("C2").Select
FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)
For i = 1 To UBound(FileNames)
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D45:O45").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D45:O45 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D8:O8").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D8:O8 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D24:O24").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D24:O24 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D33:O33").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D33:O33 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D5:O5").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D5:O5 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D38:O38").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D38:O38 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D108:O108").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D108:O108 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D10: O10 ").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D10:O10 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D131:O131").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(12, -8).Activate
'D131:O131 Line
Next i
End Sub
Paste Link Workaround
Paste Link does not work with Transpose.
Assuming that the code is in the destination workbook and that the results will be written to its ActiveSheet (rather qualify with its name e.g. "Sheet1"), you can use the followng.
The Code
Option Explicit
Sub ImportData()
' Destination
Const dstFirst As String = "C2"
' Source
Const Cols As String = "D:O"
Dim RowNumbers As Variant
RowNumbers = VBA.Array(45, 8, 24, 33, 5, 38, 108, 10, 131)
' Destination
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.ActiveSheet ' Better define: Set ws = wb.worksheets("Sheet1")
Dim dstInit As Range
Set dstInit = ws.Range(dstFirst)
' Source
Dim DataCount As Long
DataCount = ws.Columns(Cols).Count
Dim LB As Long
LB = LBound(RowNumbers)
Dim UB As Long
UB = UBound(RowNumbers)
Dim FileNames As Variant
FileNames = Application.GetOpenFilename( _
FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
Title:="Open File(s)", _
MultiSelect:=True)
Application.ScreenUpdating = False
' Prepare for loop.
Dim src As Range ' Current Source Range
Dim dst As Range ' Current Destination Range
Dim i As Long ' File Names Counter
Dim j As Long ' Destination Rows and Source Columns Counter
Dim n As Long ' Source Rows and Destination Columns Counter
Dim CurForm As String ' Current Left Part of Formula
' Write values from Source to Destination.
For i = 1 To UBound(FileNames)
With Workbooks.Open(FileNames(i)).Worksheets("Global")
CurForm = "='[" & .Parent.Name & "]" & .Name & "'!"
Set dst = dstInit.Offset((i - 1) * DataCount)
For n = LB To UB
Set src = .Columns(Cols).Rows(RowNumbers(n))
For j = 1 To DataCount
dst.Offset(j - 1, n).Formula _
= CurForm & src.Cells(j).Address(0, 0)
Next j
Next n
.Parent.Close SaveChanges:=False
End With
Next i
Application.ScreenUpdating = True
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub

Format worksheets 5 and on, then copy&paste that info into "Sheet3" with source width and format

I am currently try to make a code that will format sheets 5 and on to module one's code and then have the program copy all the information in each of those newly formatted sheets and paste them into "sheet3" with original width and format.
I have tried the "for each" and "integer" functions but can't seem to get 'the program to move past "sheet5".
This sub is suppose to go through all of the sheets and and 'format them to my needs:
Sub TEST2()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim LastRow As Long
Set wsDest = Sheets("sheet3")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name And _
ws.Name <> "sheet1" And _
ws.Name <> "sheet2" And _
ws.Name <> "sheet4" Then
'code here
Columns.Range("A:A,B:B,H:H,I:I").Delete
Columns("A").ColumnWidth = 12
Columns("B").ColumnWidth = 17
Columns("C").ColumnWidth = 10
Columns("D").ColumnWidth = 85
Columns("E").ColumnWidth = 17
ActiveSheet.Range("D:D").WrapText = True
ActiveSheet.Range("F:F").EntireColumn.Insert
ActiveSheet.Range("F1").Formula = "Product ID"
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & LastRow).Formula = "=$G$2"
ActiveSheet.Range("F2").Copy
Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End Sub
This sub is meant to go to "sheet5" first and paste it into '"sheet3", than the second half of the sub should start at "sheet6" and go on 'until the end of the work sheets and then copy & paste onto "sheet3" with 'original width.
Sub Test1()
Dim sht As Worksheet
Dim LastRow As Long
Dim WS_Count As Integer
Dim I As Integer
Sheets("Sheet5").Select
Application.CutCopyMode = False
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Range("D:D").WrapText = True
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop
For I = 5 To WS_Count
'code here
Sheets("Sheet6").Select
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Application.CutCopyMode = False
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).SelectApplication.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
'crtl shift + down
Selection.End(xlDown).Select
'moves down one cell to paste
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next I
End Sub
What im getting right now is it does "sheet5" and "sheet6" fine,but after that doesn't format and on sheet there all i get is a bunch of columns with top labeled as product ID and a bunch of 0's.
A big part of your problem is that most of your code is "assuming" that you are working with a certain worksheet when you're really working with the ActiveSheet. As an example in your TEST2 routine, you're looping through all of the worksheets in the workbook, skipping certain sheets. This part works fine. But when you want to format the other sheets, you're really only working with whatever worksheet is currently active. To fix this, you should make a habit of making sure all of your Worksheet, Range, and Cells reference are always fully qualified. So then your code works like this:
ws.Columns.Range("A:A,B:B,H:H,I:I").Delete
ws.Columns("A").ColumnWidth = 12
ws.Columns("B").ColumnWidth = 17
ws.Columns("C").ColumnWidth = 10
ws.Columns("D").ColumnWidth = 85
ws.Columns("E").ColumnWidth = 17
ws.Range("D:D").WrapText = True
ws.Range("F:F").EntireColumn.Insert
ws.Range("F1").Formula = "Product ID"
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("F2:F" & LastRow).Formula = "=$G$2"
ws.Range("F2").Copy
ws.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
Notice how every single reference is locked to the same worksheet. You can take a shortcut though, by using the With statement. But you must make sure that each reference has the . in front of it to lock it back to the With object, like this:
With ws
.Columns.Range("A:A,B:B,H:H,I:I").Delete
.Columns("A").ColumnWidth = 12
.Columns("B").ColumnWidth = 17
.Columns("C").ColumnWidth = 10
.Columns("D").ColumnWidth = 85
.Columns("E").ColumnWidth = 17
.Range("D:D").WrapText = True
.Range("F:F").EntireColumn.Insert
.Range("F1").Formula = "Product ID"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("F2:F" & LastRow).Formula = "=$G$2"
.Range("F2").Copy
.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End With
For the rest of your code, you can make improvements by avoiding the use of Select and Activate. Consider also the tips discussed in this article that will give you excellent guidance.

Excel linked IF statement loses cell range following macro update

I've created a basic macro within a workbook to clear data from a set number of tabs then copy in refreshed data from external workbooks. There is a master data tab within the workbook that uses IF formulas to obtain various stock information for that tab which then feeds through to other sheets.
E.G.
=IF($A$2="","",SUMIF(Data_CoventryStock!$A:$A,Data!$A$2,Data_CoventryStock!$E:$E))
Currently when the macro runs it produces the desired result but the IF Formulas lose the reference to the range e.g. $A:$A becomes #N/A!
I've been looking online for a solution but am unable to see a suitable option. I am new to this area.
Sub Update()
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
Sheets("Data_10Day").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CoventryStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CowleyStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_RugbyStock").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_10Day").Select
' Copies data from other workbooks then pastes
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_10Day.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_10Day").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_10Day.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CoventryStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CoventryStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CoventryStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CowleyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CowleyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CowleyStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_RugbyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_RugbyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_RugbyStock.xlsx").Close
Application.DisplayAlerts = True
End Sub
I need it to retain the cell range in the IF formula so no manual update after running the macro is required.
The reason your formulas get damaged is that you are Deleting the ranges they refer to. Instead of deleting, use ClearContents instead.
Also, your code can do with quite a bit of optimsation.
Consider this
Sub Update()
Dim wbMain As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim FilePath As String
Application.DisplayAlerts = False
Set wbMain = ActiveWorkbook
With wbMain
FilePath = Environ$("UserProfile") & "\Documents\HDS\Data\"
' Copies data from other workbooks then pastes
UpdateFromWB .Worksheets("Data_10Day").Cells(1, 1), FilePath & "Data_10Day.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CoventryStock").Cells(1, 1), FilePath & "Data_CoventryStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CowleyStock").Cells(1, 1), FilePath & "Data_CowleyStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_RugbyStock").Cells(1, 1), FilePath & "Data_RugbyStock.xlsx", "WhatSheet?"
End With
Application.DisplayAlerts = True
End Sub
Private Sub UpdateFromWB(rngDest As Range, wbName As String, wsName As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = Workbooks.Open(Filename:=wbName)
Set ws = wb.Worksheets(wsName)
With ws
Set rng = .Range(.Cells(1, 1).End(xlDown), .Cells(1, 1).End(xlToRight))
'Alternative, in case there might be gaps in the data
'Set rng = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft))
End With
rngDest.Worksheet.Cells.ClearContents 'Delets ALL data from sheet. Adjust range if required
rngDest.Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
wb.Close
End Sub
I try to create a code avoiding .Select, .Activate and repetition. The code is untested but it will give you an idea about the concept. For any question please ask me.
Option Explicit
Sub Update()
Dim ws As Worksheet
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
For Each ws In ThisWorkbook
With ws
If .Name = "Data_10Day" Or .Name = "Data_RugbyStock" Then
.Columns("A:B").Delete Shift:=xlToLeft
ElseIf .Name = "Data_CoventryStock" Or .Name = "Data_CowleyStock" Then
.Columns("A:E").Delete Shift:=xlToLeft
End If
End With
Next ws
' Copies data from other workbooks then pastes
Call Procedure("Data_10Day.xlsx", "Data_10Day")
Call Procedure("Data_CoventryStock.xlsx", "Data_CoventryStock")
Call Procedure("Data_CowleyStock.xlsx", "Data_CowleyStock")
Call Procedure("Data_RugbyStock.xlsx", "Data_RugbyStock.xlsx")
Application.DisplayAlerts = True
End Sub
Sub Procedure(ByVal FileName As String, ByVal SheetName As String)
Workbooks.Open FileName:="C:\Users\ceasdown\Documents\HDS\Data\" & FileName
Workbooks(FileName).Sheets("Sheet1").UsedRange.Copy
Workbooks("Coventry Ordering Template2.xlsm").Sheets(SheetName).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(FileName).Close
End Sub

Loop that references different sheet names each iteration

I have the following loop to create multiple tabs in Excel 2016 based on a list of PO#'s. ( see code below)
Sub CreateSheetsFromAList()
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("Instructions").Range("h6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c
For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k
End If
Next k
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
I also need to populate each newly created tab with info from another workbook (EDI PO Consolidated - 2018.xlsx)
(see code below)
Sub BandB2()
' BandB2 Macro
' Keyboard Shortcut: Ctrl+b
'
Application.Goto Reference:="R20C10"
Selection.Copy
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveSheet.Range("$A$1:$X$2628").AutoFilter Field:=2, Criteria1:= _
"34535453"
Application.Goto Reference:="R1C9"
Range("I2058").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("J26").Select
ActiveSheet.Paste
Windows("EDI PO Consolidated - 2018.xlsx").Activate
ActiveWindow.SmallScroll ToRight:=4
Application.Goto Reference:="R1C17"
Range("Q2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
ActiveWindow.SmallScroll Down:=6
Range("C33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C14"
Range("N2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("D33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("EDI PO Consolidated - 2018.xlsx").Activate
Application.Goto Reference:="R1C18"
Range("R2058:T2058").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book and Bill form - template.xlsm").Activate
Range("E33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I have 2 questions:
1) i cannot make the sheet reference change for each tab; it always picks the
1st po# "34535453"
2) Can you help me combine these into 1 macro.
thank you in advance for your help
Here's a cleaner way to create those tabs.
Name cell H6 on the Instructions tab "PO_Start" or some other appropriate name. That way if you can insert rows or columns on the tab without possibly having to change the reference to H6 in your code.
Sub Create_Sheets()
Dim PO_list, PO As Range
Set PO_list = Range(Sheets("Instructions").Range("PO_Start"), Sheets("Instructions").Range("PO_Start").End(xlDown))
Sheets("Template").Visible = True
For Each PO In PO_list
If Not WorksheetExists(PO) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = PO
End If
Next PO
End Sub
1) To loop through your tabs, if you know that your PO tabs will always start on tab 3, you can loop through the sheets like this (including variable declarations):
Sub B_and_B()
Dim ws As Worksheet
Dim i As Integer
For i = 3 To Sheets.Count
Set ws = Sheets(i)
'... rest of code here
Next i
End Sub
Otherwise if down the road you anticipate adding other sheets besides "Instructions" and "Template" to your Book and Bill file, you could loop through all sheets, error checking to see if you can convert the sheet name to a "long" variable type with Clng(). Probably more than what's needed for your current project.
Another tip:
Avoid using hard-coded cell addresses ("N2058") in your code. If you filter on purchase orders in the Consolidated book and then pull in certain data elements, you'll need to find the row the Purchase Order is in (2058 in this case).
2) To combine these into one macro, you can create a Main subroutine, calling each step separately:
Sub Main()
Call Create_Sheets
Call B_and_B
End Sub

How to enter data from a form on one sheet onto a log on another sheet

So I'm trying to figure out how I can setup a macro that will take the data that I enter into a form on one sheet then log it into a log in another sheet. It will log it but my big problem is that it needs to go to the next line and I can't quite figure out the code for it. Here is what my code looks like:
Sub Appt()
'
' Appt Macro
'
'
Range("E4").Select
Selection.Copy
Sheets("Appointments").Select
Range("G7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("D7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("E7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("F7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("H7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E4").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("E6").Select
Selection.ClearContents
Range("E8").Select
Selection.ClearContents
Range("E10").Select
Selection.ClearContents
Range("E12").Select
Selection.ClearContents
End Sub
To get the next empty row on Sheets("Appointments") you would use this formula to get the row number:
tRw = Sheets("Appointments").Range("D" & Rows.count).End(xlUp).Offset(1).Row
This assumes that there is nothing in column D below what you are pasting.
It is apparent that you used the macro recorder, and this is a great way to learn. But using the .select so much will slow things down and is unneeded.
To get around that declare the sheets as variables and then one line for each copy paste is needed.
Sub APPT()
Dim oWs As Worksheet
Dim tWs As Worksheet
Dim tRw As Long
Set oWs = Sheets("Data Entry")
Set tWs = Sheets("Appointments")
tRw = tWs.Range("D" & Rows.count).End(xlUp).Offset(1).Row
With oWs
.Range("E4").copy tWs.Range("G" & tRw)
.Range("E6").copy tWs.Range("D" & tRw)
.Range("E8").copy tWs.Range("E" & tRw)
.Range("E10").copy tWs.Range("F" & tRw)
.Range("E12").copy tWs.Range("H" & tRw)
.Range("E4").ClearContents
.Range("E6").ClearContents
.Range("E8").ClearContents
.Range("E10").ClearContents
.Range("E12").ClearContents
End With
End Sub
For other methods of finding the next row look at Siddharth Rout's answer here.
And as BruceWayne stated in his comment, this is a great reference as to why/how to avoid using .select
It's best to avoid the user's clipboard and to assign the values directly:
Sub Appt()
Dim n&, v
v = [transpose(offset('data entry'!e4,{0;2;4;6;8},))]
With Sheets("appointments")
n = .Range("d" & .Rows.Count).End(xlUp).Row
.[g1].Offset(n) = v(1)
.[d1].Offset(n) = v(2)
.[e1].Offset(n) = v(3)
.[f1].Offset(n) = v(4)
.[h1].Offset(n) = v(5)
End With
Sheets("data entry").Range("e4,e6,e8,e10,e12").ClearContents
End Sub

Resources