Good day,
May I ask if it is possible to run the macro even if some letters or characters on the title of the workbook I am working with is renamed?
this is the code I am working with:
Sub WBS()
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("Total cost.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = Workbooks("backing sheet (Jan).xlsm").Worksheets(2).Range("D6:D300")
sourceColumn.Copy
targetColumn.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Call Resource_Name
End Sub
what I really want to do is run the macro even if the name of the workbook is changed. as you can see the value I am copying is pasted on "backing sheet (Jan).xlsm" I want to change the name to "backing sheet (Feb).xlsm" and I know it wont run because the target workbook does not exist technically.
is there any possible way to deal with this?
Create a named range in your program with the date abbreviation - say called monthAbbr. Edit this every month. Then, change the VBA code to
Sub WBS()
Dim monthAbbr As String
monthAbbr = Range("monthAbbr").Value
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("Total cost.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = Workbooks("backing sheet " & monthAbbr & ".xlsm").Worksheets(2).Range("D6:D300")
sourceColumn.Copy
targetColumn.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Call Resource_Name
End Sub
I did it :). why did I make this code complicated.
incase others want to know the answer please see the code below.
Sub WBS()
Dim monthAbbr As String
monthAbbr = Range("monthAbbr").Value
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("Total cost.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = ThisWorkbook.Worksheets(2).Range("D6:D300")
sourceColumn.Copy
targetColumn.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Call Resource_Name
I forgot that there is a ThisWorkbook code. I can even change the whole name of my file :)
Related
I made this simple code, or at least tried. But I have one small problem.
When I type For I = 14 To 25 I don't really know what I'm doing. I have a sheet called "Master" and in the range K6:V6 I have every name of every sheet I want to go through. I would like to write something like this: For I = sheets("Master").range("K6:V6") But this does not work, anyone that can help to me to assign the "names" in this array to I?
The rest of the code works as it should, it could be optimized by not having "select" but I don't seem to be able to do it so I took the easy way out. Thank you for your help!
Dim I As Integer
For I = 14 To 25
If Sheets(I).Visible = False Then
'If sheet = Not visble
'-----------------------------------------------------------------------------------------------------
Sheets(I).Visible = True
AA = Sheets("Master").Range("K6").Value
Sheets(AA).Select
ActiveSheet.Unprotect
ActiveSheet.Range("C3:C120").Copy
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("C6:C120").ClearContents
ActiveSheet.Range("L6:M117").ClearContents
ActiveSheet.Protect
Range("A1").Select
Sheets(I).Visible = False
'-----------------------------------------------------------------------------------------------------
Else:
'If sheet = visble
'-----------------------------------------------------------------------------------------------------
AA = Sheets("Master").Range("K6").Value
Sheets(AA).Select
ActiveSheet.Unprotect
ActiveSheet.Range("C3:C120").Copy
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("C6:C120").ClearContents
ActiveSheet.Range("L6:M117").ClearContents
ActiveSheet.Protect
Range("A1").Select
'-----------------------------------------------------------------------------------------------------
End If
Next I
Each Worksheet in a file is held in the Worksheets collection. You can look at each worksheet in the collection in turn and act on it.
Sub Test()
Dim wrkSht As Worksheet
Dim shtMaster As Worksheet
Dim InList As Range
Dim VisibleSetting As Long
Set shtMaster = ThisWorkbook.Worksheets("Master") 'Reference to Master worksheet
'This will look at each worksheet in the worksheets collection and reference it with 'wrkSht'
For Each wrkSht In ThisWorkbook.Worksheets
'Look for the worksheet name in the K6:V6 range.
Set InList = shtMaster.Range("K6:V6").Find(wrkSht.Name, LookIn:=xlValues, LookAt:=xlWhole)
'If the name is found InList will not be nothing.
If Not InList Is Nothing Then
With wrkSht
VisibleSetting = .Visible 'Remember the visible setting.
.Visible = xlSheetVisible
.Unprotect
.Range("C3:C120").Copy
.Range("G3").PasteSpecial xlPasteValues
Union(.Range("C3:C120"), .Range("L6:M17")).ClearContents
.Visible = VisibleSetting 'Put the visible setting back.
.Protect
End With
End If
Next wrkSht
End Sub
Further reading:
ThisWorkbook
With...End With Statement
For Each...Next Statement
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 am trying to modify the below code so that it will be able to copy from one workbook to another and paste in the first empty blank cell in column A. For example if I copy and paste from A1 to E18 from one workbook, I want to be able to modify the code so that it opens a second workbook and copies and pastes the code from A19 (the first blank cell in A). I am greener than green when it comes to VBA programming. I have looked at examples for similar situations but have not been able to figure out how to apply them to what I want to do. Thank you!
Option Explicit
Sub FreezerLogImport()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
'-------------------------------------------------------------
'Open file with data to be copied
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", "Open", False)
'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
End If
'--------------------------------------------------------------
'Copy Range
wsCopyFrom.Range("A2:A5000").Copy
wsCopyTo.Range("A2:A5000").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
wsCopyFrom.Range("B2:B5000").Copy
wsCopyTo.Range("B2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
wsCopyFrom.Range("C2:C5000").Copy
wsCopyTo.Range("C2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
wsCopyFrom.Range("D2:D5000").Copy
wsCopyTo.Range("D2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
wsCopyFrom.Range("F2:F5000").Copy
wsCopyTo.Range("E2:E5000").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
' Turn off Selection of last column
Application.Selection = False
' Turn off CutCopyMode to prevent Clipboard message pop-up
Application.CutCopyMode = False
'Close file that was opened
wbCopyFrom.Close SaveChanges:=False
End Sub
.
Sub Multi_FindReplace()
'PURPOSE: Find & Replace a list of text/values throughout entire workbook
' Finds M. tuberculosis and nontuberculosis mycobacteria and replaces them with MTBC and NTM, respectively.
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim sheet1 As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long
fndList = Array("M. tuberculosis", "Unidentified nontuberculosis mycobacteria (NTM)")
rplcList = Array("MTBC", "Unidentified NTM")
'Loop through each item in Array lists
For x = LBound(fndList) To UBound(fndList)
'Loop through each worksheet in ActiveWorkbook
For Each sheet1 In ActiveWorkbook.Worksheets
sheet1.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sheet1
Next x
End Sub
I am currently working on a tool, getting some data but not the formula or other format. Just the plain text. However it gives me the error of 1004.
here's my code:
Sub WBS()
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("totalcosts.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = Workbooks("Backing sheet.xlsm").Worksheets(2).Range("C6:C300")
sourceColumn.Copy
targetColumn.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Call Resource_Name
End Sub
It always give me error on the targetcolumn.select
But when I use this code to copy and paste on the line,
*"sourceColumn.Copy destination=targetcolumn"*
It paste the data that I need. However it copies the formula instead of the value.
Cut your destination down to a single cell (top-left) and let the paste operation fill the remainder.
Sub WBS()
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("totalcosts.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = Workbooks("Backing sheet.xlsm").Worksheets(2).Range("C6")
sourceColumn.Copy
targetColumn.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Call Resource_Name
End Sub
Use the Range.PasteSpecial method directly off the target range. There is no need to Range .Select method it first¹.
Since you are only transferring the Range.Value property, a direct value transfer would be the better option.
Sub WBS()
Dim sourceColumn As Range, targetColumn As Range
Set sourceColumn = Workbooks("totalcosts.xlsm").Worksheets(3).Range("A3:A300")
Set targetColumn = Workbooks("Backing sheet.xlsm").Worksheets(2).Range("C6")
with sourceColumn
targetColumn.Resize(.Rows.Count, .Columns.Count) = .Value
end with
Call Resource_Name
End Sub
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I'm trying to track weekly quantities I have in my spread sheet. So far I've made a macro to copy and paste the info where I need it. But it will only paste it to the spot I chose while recording the macro. I'd like it to paste the info into the next available column.
I'd also like to schedule the macro to run once a week on Friday morning.
Macro I'm using now.
Sub CopyPaste()
'
' CopyPaste Macro
'
'
Range("G4:G33").Select
Selection.Copy
Range("B35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I've tried putting & lastrow into the range, but it gets a compile error. Any help would be greatly appreciated.
At first sight maybe slightly more complex, but in a way a more pretty way of tackling the movement of values is to avoid using the clipboard with code like this:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
Dim targetRng As Excel.Range
Dim destRng As Excel.Range
Set targetRng = Range("G4:G33")
Dim lc As Long
With Excel.ThisWorkbook.Sheets("Sheet1")
lc = .Cells(35, .Columns.Count).End(Excel.xlToLeft).Column
Set destRng = .Range(.Cells(35, lc), .Cells(35, lc)).Offset(0, 1).Resize(targetRng.Rows.Count, targetRng.Columns.Count)
destRng.Value = targetRng.Value
End With
End Sub
The above can be simplified to the following so you don't need to worry about using the last row variable:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
Dim targetRng As Excel.Range
Dim destRng As Excel.Range
Set targetRng = Range("G4:G33")
With Excel.ThisWorkbook.Sheets("Sheet1")
Set destRng = .Cells(35, .Columns.Count).End(Excel.xlToLeft).Offset(0, 1).Resize(targetRng.Rows.Count, targetRng.Columns.Count)
destRng.Value = targetRng.Value
End With
End Sub
You can work out the column number of the last column like this:
Sub CopyPaste()
'
' CopyPaste Macro
'
Dim lastCol As Long
' this finds the number of the last column
lastCol = Cells(35, Columns.Count).End(xlToLeft).Column
Range("G4:G33").Copy
' Range("B35").Select
' no need to select. paste into the cell in row 35, one to the right of the last column
Cells(35, lastCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
You could also add the 1 right in the lastCol definition, like
lastCol = Cells(35, Columns.Count).End(xlToLeft).Column + 1
Range("G4:G33").Copy
Cells(35, lastCol).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
For scheduling the macro look at these two questions here and here