So I have a code thats pasting data into an excel column, i'm then trying to loop through the data in that column and create a new sheet from data for every value in column B but it's stopping after completing this action once and not looping through the column.
Any ideas?
i = 4
Do While Cells(i, 2).Value <> ""
Worksheets("Front").Cells(5, 3).Value = Cells(i, 2)
Worksheets("Front").Select
Range("C2:M35").Select
Selection.Copy
Sheets("PlaceHolder").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Dim wks As Worksheet
Set wks = ActiveSheet
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = wks.Range("C5").Value
i = i + 1
Loop
"Cells" and "Range" in your code both refer to the ActiveWorksheet, which presumably starts out as Worksheets("Front"), then you change ActiveWorksheet to Worksheets("Placeholder") with the Worksheets("Placeholder").Select statement. I'm not sure if creating the new worksheet sets ActiveWorksheet to the new worksheet or not and I shouldn't have to know to make the code work. Instead of relying on the implicit reference to ActiveWorksheet, you should use explicit references like this.
'Style note: Always put Option Explict at the top of the module
'and declare all your variables at the top of the subroutine.
Dim wsFront As Worksheet
Dim wsPlaceholder As Worksheet
Dim wsNewSheet As Worksheet
Dim i As Integer
Set wsFront = Worksheets("Front")
Set wsPlaceholder = Worksheets("Placeholder")
i = 4
Do While wsFront.Cells(i, 2).Value <> ""
' Copy data from Worksheets("Front")
wsFront.Cells(5, 3).Value = Cells(i, 2)
wsFront.Select
wsFront.Range("C2:M35").Select
Selection.Copy
' Paste data to Worksheets("Placeholder")
wsPlaceholder.Select
wsPlaceholder.Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
' Copy Worksheets("Placeholder") to new worksheet
wsPlaceholder.Copy After:=Worksheets(Sheets.Count)
'Get a reference to the new worksheet
Set wsNewSheet = Worksheets(Worksheets.Count)
wsNewSheet.Name = wsPlaceholder.Range("C5").Value
i = i + 1
Loop
There's typically no need to select or activate anything when using VBA in Excel (despite what the macro recorder might try to suggest)
If you plan on doing much VBA work in Excel then this is highly-recommended reading:
How to avoid using Select in Excel VBA
Dim wsData As Worksheet, wsFront As Worksheet, wsPH As Worksheet, v
Dim wb As Workbook, i As Long
Set wb = ThisWorkbook
Set wsData = ActiveSheet 'or some other specific sheet
Set wsFront = wb.Worksheets("Front")
Set wsPH = wb.Worksheets("PlaceHolder")
i = 4
Do While wsData.Cells(i, 2).Value <> ""
v = wsData.Cells(i, 2).Value
wsFront.Cells(5, 3).Value = v
wsFront.Range("C2:M35").Copy
With wsPH.Range("C2")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
wsPH.Copy After:=wb.Worksheets(Sheets.Count)
wb.Worksheets(Sheets.Count).Name = v
Loop
Related
This code worked once and then stopped. It runs with no action or errors.
I would like if column "a" of the "export" sheet has a yes to copy the cells from B to J to the next clear line in workbook MOSTEST sheet1 (named 11.2022).
Sub DateSave()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 1).Value = "YES" Then
Range(Cells(i, 2), Cells(i, 10)).Select
Selection.Copy
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx"
Worksheets("11.2022").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
If changed the "Worksheets("11.2022").Select" to sheet1 which I would prefer as I wouldn't have to change it every month.
You should try to avoid using select, see other post
I adjusted your code where needed, I'm still trying to figure out best practice (i.e. it would be better adding the cell ranges to a range variable and then pasting them in one go but I'm not quite there yet) when it comes to minimizing code so if others can do better, feel free :)
Sub DateSave()
Dim LastRow As Long, i As Long, erow As Long
Dim wsStr As String
Dim ws As Worksheet, wsC As Worksheet
Dim wb As Workbook, wbM As Workbook
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
Set wb = ActiveWorkbook
Set wsC = wb.Sheets("EXPORT")
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx" 'Don't keep opening and saving/closing your workbook per copy, that would heavily increase runtime
Set wbM = Workbooks("MOSTEST.xlsx")
wsStr = Month(Date) & "." & Year(Date)
Set ws = wbM.Worksheets(wsStr) 'If your currentmonth will always be the first sheet then you can use wbM.Sheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Row
wb.Activate
For i = 1 To LastRow
If wsC.Cells(i, 1).Value = "YES" Then
erow = erow + 1
wsC.Range(wsC.Cells(i, 2), wsC.Cells(i, 10)).Copy 'avoid select
ws.Range("A" & erow).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next i
wbM.Save
wbM.Close
Application.CutCopyMode = False
End Sub
If you have questions, feel free to ask!
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.
I am doing an Excel Workbook project for a poker room. There is a Player Database within the program. Each player has an ID number.
For the sake of my question I'm going to refer to two Sheets.
When a player comes in for that day they are logged in with Name, ID, and Time (This sheet is Worksheets("Cashout")). Cashout Sheet
Then when the player buys poker chips they get added to another sheet (Worksheets("Tab")).Tab Sheet This sheet keeps track of the chips that are purchased. Some of these players get loans from the house so they end up with a Tab. On the "Tab" sheet there is a cmd button called Cashout.
When the player is done for the day the goal is to click the cashout button and submit any remaining tab and the players end time to the "Cashout" sheet. Since both of these sheets have the players ID number, I am thinking that is how I should find the record on the Cashout page, but let me know if there is an easier way.
I have it working with using do loops and ActiveCell select, but it is a lot of code, and select slows the process. I know there is a better way to do this possibly Find, Match or even a For Each loop. Please let me know to change my code.
I am attaching the code that works, but I don't want to use it.
Private Sub CmdBtnCashout1_Click()
Dim LastRow As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cnt As Integer
Set ws1 = Worksheets("Tab")
Set ws2 = Worksheets("Cashout")
Set Rng1 = Worksheets("Tab").Range("A5")
Set Rng2 = Worksheets("Tab").Range("C4")
Set Rng3 = Worksheets("Tab").Range("W5")
cnt = 1
Application.ScreenUpdating = False
Rng1.Select
Selection.Copy
ws2.Activate
ws2.Range("A4").Select
If ws2.Range("A4") = "" Then
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws1.Activate
Rng2.Select
Application.CutCopyMode = False
Selection.Copy
ws2.Activate
ActiveCell.Offset(0, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws1.Activate
Rng3.Select
Application.CutCopyMode = False
Selection.Copy
ws2.Activate
ActiveCell.Offset(0, 3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws2.Range("A1").Select
ws1.Activate
ws1.Range("A1").Select
Application.CutCopyMode = False
Range("A1").Select
Else
Do Until ActiveCell.value = ""
ActiveCell.Offset(1, 0).Select
cnt = cnt + 1
If cnt > 49 Then Exit Do
Loop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws1.Activate
Rng2.Select
Application.CutCopyMode = False
Selection.Copy
ws2.Activate
ActiveCell.Offset(0, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws1.Activate
Rng3.Select
Application.CutCopyMode = False
Selection.Copy
ws2.Activate
ActiveCell.Offset(0, 3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws2.Range("A1").Select
ws1.Activate
ws1.Range("A1").Select
Application.CutCopyMode = False
Range("A1").Select
End If
Application.ScreenUpdating = True
End Sub
Tab sheet: with Cashout Button: the player name is in Cell A5, ID number is in A4, tab balance is in W5.
Cashout Sheet: player name is within the range of A4:A53 and Player ID number is in range of B4:B53 this is where i would need to match my reference then insert the tab balance from the Tab Sheet in range G4:G53 on the row with that player. I also want to just insert the time stamp in E4:E53.
The sub would be worksheet level sub on the Tab Sheet using the CashoutCommandBtn Click event
How should I do this?
I found a way to do this see the attached code which works perfectly except I have 20 subs for 20 buttons. I know there is a way for me to put the long code into a module and call it from a sub so I am going to try and work on that so that the 20 subs have at least minimal code instead of the long code.
\\
Private Sub CmdBtnCashout1_Click()
Dim Rng2 As Range
Dim TimeOut As Date
Dim wst As Worksheet
Dim wsco As Worksheet
Dim Rng1 As Range
Dim Balance As Range
Dim COPlayer As Range
Dim COPlayerRng As Range
Dim i As Integer
Dim j As Integer
Dim Urng1 As Range
Dim Urng2 As Range
Dim UnionRng As Range
Dim WinLoss As Range
Dim ChipReturn As Range
Set COPlayerRng = Worksheets("Cashout").Range("B4:B53")
Set wst = Worksheets("Tab")
Set wsco = Worksheets("Cashout")
i = 4
j = 5
Set Rng1 = Worksheets("Tab").Cells(i, 1)
Set Rng2 = Worksheets("Tab").Cells(1, 1)
Set Balance = Worksheets("Tab").Cells(j, 23)
Set WinLoss = Worksheets("Tab").Cells(j, 24)
Set COPlayer = COPlayerRng.Find(What:=Rng1.value,LookIn:=xlValues,LookAt:=xlWhole)
Set Urng1 = wst.Range(Cells(i, 1), Cells(j, 1))
Set Urng2 = wst.Range(Cells(i, 3), Cells(j, 22))
Set UnionRng = Union(Urng1, Urng2)
Set ChipReturn = wst.Range(Cells(i, 25), Cells(j, 25))
TimeOut = Time
Application.ScreenUpdating = False
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
With COPlayer
.Offset(0, 7).value = Balance.value
.Offset(0, 3).value = TimeOut
.Offset(0, 6).value = WinLoss.value
End With
Rng2.Select
UnionRng.ClearContents
ChipReturn.ClearContents
wst.Range("A6:V43").Copy
wst.Range("A4").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
wst.Range("A1").Select
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
Application.ScreenUpdating = True
End Sub
\\
By using a few variables and the "find" function and "with" statement provided me with a solution that works. I am still new to VBA so if there is any way to streamline this code or to use a standard module and calling a sub from there to eliminate the code for 20 buttons let me know. The variables "i" and "j" are used to count rows in the Cells Property. The code above is for one of the buttons on the worksheet. when the command button is pressed the it looks for the matching value for the ID number. After that is complete it takes the data from cell "A4" and "A5 and "C4" and "V5" and moves that information to another worksheet. the variables "i" = 4 and "j" = 5. The next button code is identical except since the row changes "i" = 6 and "J" = 7 and so on.
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
I have researched this issue on several different sites with no clear way to do what I want:
I have a spreadsheet with 68 pairs of columns from 'B' to 'EG' and one leading column of data in 'A'.
I want create a new worksheet and name it for the header for the first column of each pair of columns, then copy the column of data in 'A' and the pair of columns into the new worksheet, and do the same for each succeeding pair of columns. I can create the new worksheets from the existing spreadsheet data, but not sure how to name the new worksheets to match the header field.
The following code will create a new worksheet and copy the data, but it won't name the worksheet, and I have to create 68 separate blocks for each succeeding pair of columns! Can anyone suggest a mod to the code to loop through the columns and do what I want? Generated code is below! And any real help would be very much appreciated.
Thanks Mike
Code:
Sub testcopy()
testcopy Macro
Keyboard Shortcut: Ctrl+f
Range("A5:A17,B5:B17,C5:C17").Select
Range("C5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("A5:A17,D5:D17,E5:E17").Select
Range("E5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
.
.
.
End Sub
Something like this:
Sub testcopy()
Dim shtSrc As Worksheet, sht As Worksheet
Dim i As Long, rngA As Range, rngTwo As Range
Set rngA = ActiveSheet.Range("A5:A17")
Set rngTwo = ActiveSheet.Range("B5:C17")
For i = 1 To 68
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = rngTwo.Cells(1).Value
Application.Union(rngA, rngTwo).Copy
sht.Range("A5").PasteSpecial Paste:=xlPasteValues
Set rngTwo = rngTwo.Offset(0, 2)
Next i
End Sub