Loop that references different sheet names each iteration - excel

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

Related

How to add data daily on the first blank line? Canteen example

I have the following set of code to record daily employees who eat lunch in the canteen. What change is needed so that when the person clicks on the macro button every day, the data is on the 1st blank line (from column A) of the "dados_diarios" sheet?
This is so that at the end of the month I have a list of all the days.
Sub outros_diario()
Sheets("outros").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Workbooks.Open ("N:\RH\Cantina\Lista_OUTROS.xlsx")
Windows("Lista_OUTROS.xlsx").Activate
Cells.Select
Selection.Copy
Windows("outros.xlsm").Activate
Sheets("outros").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.DisplayGridlines = False
Range("B8:O1000").Select
Selection.Copy
Sheets("dados_diarios").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2:F1000").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("E2:H1000").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Range("H8").Select
Columns("C:C").EntireColumn.AutoFit
End Sub
Give this a go. You may want to add back in your DisplayGridlines= False and the deletion of cells at the end - but it should give you a much better start than where you're up to right now:
Sub outros_diario()
'declarations
Dim last_row_source As Long
Dim last_row_destination As Long
Dim source_book As Workbook
Dim source_sheet As Worksheet
Dim dest_sheet1 As Worksheet
Dim dest_sheet2 As Worksheet
'set references to the two paste destinations
Set dest_sheet1 = ThisWorkbook.Sheets("outros")
Set dest_sheet2 = ThisWorkbook.Sheets("dados_diarios")
'delete-clear sheet: outros
dest_sheet1.Cells.Delete Shift:=xlUp
'open the workbook as reference 'source_book'
Set source_book = Workbooks.Open("N:\RH\Cantina\Lista_OUTROS.xlsx")
'set a reference to the activesheet and call it 'source_sheet'
Set source_sheet = source_book.ActiveSheet
'copy source_sheet to dest_sheet1 [outros]
source_sheet.Cells.Copy dest_sheet1.Range("A1")
'find where the data now stops on the [outros]
last_row_source = dest_sheet1.Cells(dest_sheet1.Rows.Count, "B").End(xlUp).Row
'find where the data stops on [dados_diarios]
last_row_destination = dest_sheet2.Cells(dest_sheet2.Rows.Count, "B").End(xlUp).Row
'copy data values from [outros] to [dados_diarios] ignoring first 7 rows
dest_sheet2.Range("A" & last_row_destination + 1).Resize(last_row_source - 7, 14).Value = dest_sheet1.Range("B8:O" & last_row_source).Value
'close the source workbook, without saving
source_book.Close False
End Sub

Paste Special macro Excel

Sub Copy_Cell2()
'Declare Variables
Dim Wr As Worksheet
'Define the excel sheet
Set Wr = ThisWorkbook.Sheets("Sheet2")
'Code to stop screen updating and flickering ON
Application.ScreenUpdating = False
'Select Sheet1 to get the random value
Sheets("Sheet1").Select
Cells.Select
Range("F1").Select
Range("F1").Copy
'Selects Sheet2 to paste the random value in the next blank cell in column A
Sheets("Sheet2").Select
Range("A2").Select
nrlife = Wr.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
'Establish what row has been selected
With ActiveCell
vRow = .Row
End With
vRange = "A" & vRow & ""
Range(vRange).Select
'Code to paste value and format from Sheet1 to first empty row on sheet2
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
'Code to stop screen updating and flickering OFF
Application.ScreenUpdating = True
End Sub
I am getting error in Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
Error code is Run-time error '1004' Aplication-defined or
object-defined error
Can anyone help me what am i missing?
Your code reduces to:
Dim wb As Workbook
Set wb = ThisWorkbook
wb.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = _
wb.Sheets("Sheet1").Range("F1").Value
You can assign values directly - no need for copy/paste in this case.

Excel dynamic drop downs based on previous selection

Good day,
I could only find examples where the tables are quite simple and the data minimal. I'm sitting with 36 makes, and up to 3 072 variants on the below data which I need sorted out.
The below col A through E is an extract of my data, with col G through I, the selections I need to make. To explain.
Blockquote
Col G: Should be a drop down with the values from Col C (which is easy and is done already)
Blockquote
Col H: If I now select Abarth in Col G, I only want the 500/695 or 124 displayed in a drop down, where I will choose 124
Blockquote
Col I: Similar to Col H, now only Abarth 124 related items should be displayed in the drop down
SOLVED! I have written macros to resolve as follows:
Sub SelectModel()
'
' SelecModel Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
ActiveCell.Copy Destination:=Sheets("2018MMCodes").Range("AU1")
Sheets("2018MMCodes").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Columns("AV:AX").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C$3257").RemoveDuplicates Columns:=2, Header:= _
xlYes
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub
Sub SelectVariant()
'
' SelectVariant Macro
'
'
ActiveCell.Select
' Save the active cell to use later
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
Selection.Copy
Sheets("2018MMCodes").Select
Range("AU3").Select
ActiveSheet.Paste
Columns("AV:AX").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("AV1:AX3257").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("'2018MMCodes'!Criteria"), Unique:=False
Selection.Copy
Sheets("Selections").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Returns the user to the original sheet to enable just making a selection
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub

Copy Three Columns from one workbook into another when all three ranges are different than the original ranges using Command Button

I am attempting to copy three ranges, Column A, B and C in Workbook 1 to columns B, C, and G in Workbook 2 using a command button and without having to have the destination workbook open. Here, Column A from WB1 goes to column B WB2, Column B from WB1 goes to column C WB2, and Column C from WB1 goes to column G WB2.
I've been able to copy and paste A and B into B and C using the following Code, but cannot figure out how to get C into G without using a different Command Button.
I need the button to completely update the columns in the destination worksheet when it is clicked.
This is how I went about the first two columns :
Private Sub CommandButton1_Click()
ActiveSheet.Range("A2:B250").Copy
Workbooks.Open Filename:="C:\Users\og677\Desktop\N
\Matlab\VehicleList1.xlsx"
ActiveSheet.Cells(2, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, skipblanks:=False, Transpose:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End Sub
I thought I might need to set the ranges so I was trying something like this, but I didn't know how and was getting in error where I attempt to set wb2.
Private Sub CommandButton1_Click()
Dim O As Workbook
Dim wb2 As Workbook
Dim ESN As Worksheet
Dim List As Worksheet
Dim I As Integer
Dim n As Integer
Set O = ThisWorkbook
Set wb2 = Workbooks("C:\Users.xlsx")
Set ESN = O.Sheets("ESN Regression")
Set List = VehicleList.Sheets("Sheet1")
n = 2
For I = 2 To WorksheetFunction.CountA(O.Columns.EntireColumn(1))
If Cells(I, "I").Value = "Yes" Then
List.Cells(n, "B").Value = ESN.Cells(I, "A")
List.Cells(n, "C").Value = ESN.Cells(I, "B")
List.Cells(n, "G").Value = ESN.Cells(I, "C")
n = n + 1
End If
Next
End Sub
I'd like to be able to keep my first attempt if it could be done but I'm open to any changes at all.
Here's what I came up with:
Private Sub CommandButton1_Click()
ActiveSheet.Range("A2:B250").Copy
Workbooks.Open Filename:="C:\Users\og677\Desktop\N\Matlab\VehicleList.xlsx"
ActiveSheet.Cells(2, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, skipblanks:=False, Transpose:=False
Application.CutCopyMode = False
ThisWorkbook.Activate
ActiveSheet.Range("C2:C250").Copy
Windows("VehicleList.xlsx").Activate
ActiveSheet.Cells(2, 7).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, skipblanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
End Sub
You can specify the range where you want to paste.
This is how I did in my macro to copy from wbTarget column A to wbThis column B
wbTarget.Sheets("sheet1").Range("A14:A100").Copy
wbThis.Activate
wbThis.Sheets("Sheet1").Range("B14:B100").PasteSpecial Paste:=xlPasteValues
Split the copy/paste in more steps called by the same Command, so that A and B are pasted to A and B, while C is pasted to G
Try this code.
Private Sub CommandButton1_Click()
Workbooks.Open Filename:="enter file name.xlsx"
'Column A
Windows("Workbook1.xlsm").Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Workbook2.xlsx").Activate
Range("B1").Select
ActiveSheet.Paste
'Column B
Windows("Workbook1.xlsm").Activate
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Workbook2.xlsx").Activate
Range("C1").Select
ActiveSheet.Paste
'Column C
Windows("Workbook1.xlsm").Activate
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Workbook2.xlsx").Activate
Range("G1").Select
ActiveSheet.Paste
Range("A1").Select
End Sub

I Need a Excel VBA code for to copy paste a range of cell

To be short and sweet with my requirement, I need a code to do the conditions below.
Select from range A2:G5
Then check if a sheet named with current date i:e 29-02-2016
If yes,
then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
If no,
create a new sheet and name it with current date and then copy paste the range in A1 leave 3 rows below for the next data to be pasted below that.
I tried the below code but it give me error once the current date sheet is created.
Sub Macro1()
Sheets("Sheet1").Select
Range("D3:G12").Select
Selection.Copy
sheets = "todaysdate".select
Dim todaysdate As String
todaysdate = Format(Date, "dd-mm-yyyy")
AddNew:
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = todaysdate
On Error GoTo AddNew
Sheets(todaysdate).Select
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Try these modifications.
Sub Macro1()
Dim todaysdate As String
With Worksheets("Sheet1")
.Range("D3:G12").Copy
End With
todaysdate = Format(Date, "dd-mm-yyyy")
On Error GoTo AddNew
With Worksheets(todaysdate)
On Error GoTo 0
With .Cells(Rows.Count, "A").End(xlUp).Offset(3, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
Exit Sub
AddNew:
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = todaysdate
With .Cells(Rows.Count, "A").End(xlUp)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End Sub
Step through the modified procedure with the [F8] key to watch how it handles the thrown error and continues on to exit or processes the paste with a three row offset.

Resources