The code below copies data from a specific column and transfers it to another one. For example, if in column A I have data from row 1 to 10 and press the button, then the values from row 1 to 10 will be transferred to i.e. column D. Afterwards, If I change the values in row 5, 7 and 9 in column A and press the button, only the values from row 5, 7 and 9 will be transferred to column D. The reason why the code is like that is because the worksheet has many rows filled with values and I want to be transferred (copy) only the values that have been modified. Otherwise, it will take quite some time.
The code works, but sometimes I get the error The commnand cannot be used on multiple selections. I tried to have a look on the internet to fix it but I couldn't come up with any solutions. Any help will be appreciated!
Note: A user from this community helped me to write the code below a time ago, but I cannot find the link anymore for that.
This code is pasted in the worksheet that I am using:
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim creation As Worksheet
Set creation = ActiveSheet
Dim copydata As Range
Set copydata = Application.Intersect(target, creation.Range("A2:A5000", "A" & creation.Rows.Count))
If (Not copydata Is Nothing) Then
If (CopyDataRange Is Nothing) Then
Set CopyDataRange = copydata
Else
Set CopyDataRange = Application.Union(CopyDataRange, copydata)
End If
End If
End Sub
And this code is pasted in a module:
Option Explicit
Public CopyDataRange As Range
Public Sub CommandButton1_Click()
Application.ScreenUpdating = False
If (Not CopyDataRange Is Nothing) Then
CopyDataRange.Copy
CopyDataRange.Offset(0, 3).PasteSpecial Paste:=xlPasteValues ' this where I get the error
Set CopyDataRange = Nothing
End If
Application.ScreenUpdating = True
End Sub
PasteSpecial doesn't work on multiple ranges. You can loop over all parts of the range using the Areas property:
if Not CopyDataRange Is Nothing then
Dim r As Range
For Each r In CopyDataRange.Areas
r.Copy
r.Offset(0, 3).PasteSpecial Paste:=xlPasteValues
Next
set CopyDataRange = nothing
end if
This will work even if you don't have a multiple range, in that case it contains only one Area (Areas.Count = 1)
Related
I'm copying values as part of one sub process and pasting value through an update button on userform.
To copy values:
Private Sub Month1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = Workbooks.Open("Place on drive")
Set wks = wkb.Sheets("Training1")
wks.Range("Start:Finish").Copy
wkb.Close
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
End Sub
To paste values in current sheet:
Private Sub UpdateActuals_Click()
For i = 1 To 12
If Me.Controls("Month" & i).Value = True Then
ThisWorkbook.Sheets("2017 Actuals").Range(i+1, 5).PasteSpecial xlPasteValues
End If
Next i
End Sub
If I replace "i+1, 5" with "B5", it errors with
"PasteSpecial method of Range class failed".
I feel as if values copied in one sub process are not brought to second one, would that be correct?
Also, how do I reduce processing time given that I have 12 months (12 files) in various places that I can't change the location for...
Range usually likes a starting cell and an ending cell. I suggest since you are looking at just one cell that you change .Range to .Cells. If you really want to use a range with RC format, .Range(Cells(row1, col1), Cells(row2, col2)), if you want just one cell then you can make the two parts the same. I have run into problems before using Range and only one cell definition before, either make it .Cells for your target or fill out Range the way I have explained.. Cheers.
Dim 2017actWS AS Worksheet
Set 2017actWS = ThisWorkbook.Worksheets("2017 Actuals")
1)
2017actWS.Cells(i+1, 5).PasteSpecial xlPasteValues
-or-
2)
2017actWS.Range(2017actWS.Cells(i+1, 5), 2017actWS.Cells(i+1,5)).PasteSpecial xlPasteValues
When using Ranges excel will often throw errors if they are not the same size in a copy and paste, you can eliminate that by using a single cell as the starting target of your paste with .Cells
Also I don't see you call your function. You will want your paste close to your copy or you might find things get strange (suggestion: just after your copy).
Edited to be sure there is not worksheeet ambiguity. Thank you Scott C.
Cheers, WWC
I once built a VBA button to automatically lock all cells with data in them. And it was working perfectly. Now I wanted to copy that button to another worksheet. So I created another button, copy and pasted the whole VBA over, then edited the worksheet names and range. And, it's only working like 5% of the time, the rest of the time, I'm getting an "Run-Time error '1004': No cells were found." I've tried a few fixed, changing Sheets to Worksheets, or adding a ", 23" to the specialcells argument. However, nothing is working right now. When I try stepping in, it sometimes say both rng and lckrng as empty, and sometimes only show lockrng as empty and not show rng at all. Problem is this used to be a working code, and now, it still works around 5% of time. Any idea why? Thank you very much!
Private Sub CommandButton1_Click()
Dim rng As Range
Dim lockrng As Range
Sheets("Uploading Checklist (M)").Unprotect Password:="signature"
Set rng = Range("A1:M14")
'Selecting hardcoded data and formulas
Set lockrng = Union(rng.SpecialCells(xlCellTypeConstants), rng.SpecialCells(xlCellTypeFormulas))
lockrng.Locked = True
Sheets("Uploading Checklist (M)").Protect Password:="signature"
End Sub
Maybe this is too simplistic, but it seems to do what you want. The animated .gif shows it working to "lock all cells with data in them". (I made the second button just for convenience). If nothing else it might be good to start from something like this that works and modify to suit your needs.
Dim cell As Range, sh As Worksheet
Sub Button4_Click()
Set sh = Worksheets("Sheet1")
sh.Unprotect Password:="s"
For Each cell In sh.UsedRange
If cell <> "" Then cell.Locked = True Else cell.Locked = False
Next
sh.Protect Password:="s"
End Sub
Sub Button5_Click()
Set sh = Worksheets("Sheet1")
sh.Unprotect Password:="s"
End Sub
The Union you are attempting will not work if either of the parameters is Nothing (i.e. you either have no constants in the range, or you have no formulas in the range).
Prior to doing the Union, you should check the parameters aren't Nothing but, once you start changing your code to do that, it would be just as simple to do the locking in two parts - so I recommend you rewrite the code as follows:
Private Sub CommandButton1_Click()
With Sheets("Uploading Checklist (M)")
.Unprotect Password:="signature"
With .Range("A1:M14")
'Lock any constants
If Not .SpecialCells(xlCellTypeConstants) Is Nothing Then
.SpecialCells(xlCellTypeConstants).Locked = True
End If
'Lock any formulas
If Not .SpecialCells(xlCellTypeFormulas) Is Nothing Then
.SpecialCells(xlCellTypeFormulas).Locked = True
End If
End With
.Protect Password:="signature"
End With
End Sub
I'm having a bit of a problem with this VBA code
Sub upONGOING_Train1()
ScreenUpdating = False
'set variables
Dim rFndCell As Range
Dim strData As String
Dim stFnd As String
Dim fCol As Integer
Dim oCol As Integer
Dim SH As Worksheet
Dim WS As Worksheet
Dim strFName As String
Dim objCell As Object
Set WS = ThisWorkbook.Sheets("Trains")
For Each objCell In WS.Range("L3:L100")
oCol = objCell.Column
strFName = WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
On Error GoTo BLANK: 'skip macro if no train
Workbooks.Open Filename:=strFName 'open ongoing report
Set SH = Worksheets("Trains") 'set sheet
stFnd = WS.Cells(, oCol).Offset(objCell.Row - 1, 2).Value 'set connote
With SH
Set rFndCell = .Range("C3:C1100").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
WS.Cells(, oCol).Offset(objCell.Row - 1, 3).Resize(1, 6).Copy
SH.Cells(, fCol).Offset(rFndCell.Row - 1, 10).Resize(1, 6).PasteSpecial xlPasteValues 'paste values in ongoing report if connote found
ActiveWorkbook.Save 'save ongoing report
ActiveWorkbook.Close 'close ongoing report
Else 'Can't find the item
End If
End With
BLANK:
Next objCell
ScreenUpdating = True
End Sub
What I want it to do is - for every row in L3:L100
Open file listed in column "L" (if there or skip line to next one) and go to sheet
Match value from original sheet column "N" to "C3:C1100" in newly opened sheet
Copy columns "O:T" and paste relative to the matching value in the opened sheet(M:R) and save
However when I leave a gap of 2 rows it gives me the error for file not found instead of proceeding to the next loop like it does when there is only 1 row missing.
Seems i can't post images yet.
Also if anyone can point me in a good direction on how to open the sheet in the cell reference only if it is not already open it will usually only have 2 files to use (max of 4 at end of quarter).
Its just too much trouble to click OK on all the windows that pop up when you try to reopen an already open workbook.
If its any help to get your head around it.
I have 2 separate reports for 2 clients(new each quarter so max of 4 sheets at a time) that will already have the names to be searched (2 sheets in each book).
Any help would be greatly appreciated
Thanks heaps
Thanks to those who have put forth suggestions and code.
I'll them out tomorrow and failing that I've just come up with another idea that to re-purpose some other code I have but didn't realize would help.
The code basically copies what I need to a blank tab and deletes rows with a given value - with some formulas to help sort this would give me a block of rows with no breaks all going to the same destination file.
Thus allowing me to run the (a bit more streamlined Thanks everyone) loop over the remaining rows.
On Error GoTo BLANK
Workbooks.Open Filename:=strFName
Change the above into this:
On Error Resume Next
Workbooks.Open Filename:=strFName
If Err.Number <> 0 Then Goto Blank
As to hpw keep the workbook open, you can leave it open (no .close) but then when you want to open it check first if it is open (i.e. using Workbooks("name")), with some error handling using the same mechanism as above, if error exists then the wb is not already open, you open it.
Finally, avoid counting on the Active stuff, such as the ActiveWorkbook`. Instead, make an explicit reference to you wb, i.e.:
Set wb = Workbooks.Open(Filename:=strFName)
Set SH = wb.Worksheets("Trains")
to consider only not blank cells you can use SpecialCells() method of Range object and leave off any On Error GoTo statements, that should be used in very a few limited cases (one of which we'll see in a second)
furthermore you're using some uselessly long winded 'loops' to reference your relevant cells, for instance:
WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
is equivalent to objCell itself!
and there are some more examples of that kind
finally, let's come to the workbooks open/close issue
you could:
use a Dictionary object to store the name of all opened workbooks so as to leave then open throughout your macro and close them all by the end of it
adopt a helper function that tries to set the wanted sheet (i.e. "Trains") in the wanted workbook (i.e. the one whose name is the current objCell value) and return False if not successful
all what above in this refactoring of your code:
Sub upONGOING_Train1bis()
Dim rFndCell As Range
Dim SH As Worksheet
Dim objCell As Range
Dim shtDict As New Scripting.Dictionary '<--| this is the dictionary that will store every opened workbook name as its 'keys'
Dim key As Variant
' Dim dec As String '<--| do you actually need it?
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Trains") '<-- reference your working worksheet
' dec = .Range("L1") '<-- what's this for? in any case take it out of for loops since its value doesn't depend on current loop variables
For Each objCell In .Range("L3:L100").SpecialCells(xlCellTypeConstants) '<--| loop through L3:L100 range not blank cells only
If TrySetWorksheet(objCell.Value, "Trains", SH) Then '<--|Try to set the wanted worksheet in the wanted workbook: if successful it'd retrun 'True' and leave you with 'SH' variable set to the wanted worksheet
shtDict(SH.Parent.Name) = shtDict(SH.Parent.Name) + 1
Set rFndCell = SH.Range("C3:C1100").Find(objCell.Offset(, 2).Value, LookIn:=xlValues, lookAt:=xlWhole) '<--| specify at least 'LookIn' and 'LookAt' parameters
If Not rFndCell Is Nothing Then rFndCell.Offset(, 10).Resize(, 6).Value = objCell.Offset(, 3).Resize(, 6).Value
End If
Next objCell
End With
For Each key In shtDict.Keys '<--|loop through opened workbooks dictionary keys
Workbooks(key).Close True '<--| close workbook whose name corresponds to current dictionary key
Next
Application.ScreenUpdating = True
End Sub
Function TrySetWorksheet(fileName As String, shtname As String, sht As Worksheet) As Boolean
Set sht = Nothing
On Error Resume Next
Set sht = Workbooks(Right(fileName, Len(fileName) - InStrRev(fileName, "\"))).Worksheets(shtname) '<--| try looking for an already open workbook with wanted name and wanted sheet
If sht Is Nothing Then Set sht = Workbooks.Open(fileName:=fileName).Worksheets(shtname) '<--| if not found then try opening the wanted workbook and set the wanted sheet in it
TrySetWorksheet = Not sht Is Nothing '<--| set the return value to the final result of attempts at locating the wanted sheet
End Function
First time poster, been searching for a solution to this all over but no luck yet.
To explain my problem:
TERMS:
OPC = Object Linking and Embedding (OLE) for Process Control
(allows other applications to use data from PLC tags)
PLC = Programmable Logic Controller (computer for process control
SCADA = Supervisory Control And Data Acquisition (interface that displays values from PLC and allows control)
I have an excel workbook which is automatically opened by the SCADA system (WonderWare > Intouch, the software) at a specific time after the PLC has sorted some values. This workbook populates its cells using the OPC client, accessing them using this method:
=OPCLINK|EAST!'r[BELLWWPOWER]DailyValues_Z3[1,21]'
This works well but there are a lot of cells to populate so it takes a few seconds.
What I want to automatically happen is for these cells to populate and any calculations to complete before all the cells with formulas are changed to just the values of those formulas. The workbook is then saved under a new workbook name ("PowerReports-YesterdaysDate") with the VBA code stripped and both workbooks are closed (without saving the original, to preserve formulas).
This all works well except it happens too fast and the new saved copy ends up having just "#N/A" in all the cells with OPC links. When I had the first sheet's private sub as "Worksheet_Activate()" instead of "Worksheet_Calculate()", the code wouldn't stat automatically and waited for a mouse click onto one of the sheet's cells (FYI: the SCADA system opens this workbook to sheet 1 automatically to start with sheet 1's code). The new copy would save successfully in this case, but when the code stats automatically it is too fast. How can I wait for the external data to load before the calculations are done?
I've tried things (I don't know how successfully they were implemented..) like:
-Application.Calculate
-Application.RefreshAll
-Timers
-Trying to get a flag from the PLC
-Checking for remaining #N/As
It seems like if a loop or something similar is running right away it doesn't let the external data refresh.
Private Sub Worksheet_Calculate()
' When first sheet "Main" is activated, all formulas are replaced
' with their calculated values. The second sheet, "Monthly Values" is then activated
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End Sub
Private Sub Worksheet_Activate()
' When second sheet "Monthly Values" is activated, all formulas are replaced
' with their calculated values. The sub routine, "SaveWithoutMacros" is then called
Dim rng As Range, r As Range
Set rng = Range("A1:BJ84")
'Worksheets("Monthly Data").Calculate
'If Not Application.CalculationState = xlDone Then
'DoEvents
'End If
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Call SaveWithoutMacros
End Sub
Sub SaveWithoutMacros()
'Purpose : To save a copy of the active workbook without macros
Dim vFilename As String
Dim wbActiveBook As Workbook
'----------------------------------------------------------------------
'Following two lines causes an error in Excel 97 - comment them out
Dim VBComp As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
'----------------------------------------------------------------------
' Save to filename in format (yesterdays date) "PowerReports-DD-MM-YYYY"
vFilename = ("D:\PowerReports\" & "PowerReport-" _
& Format(Date - 1, "DD-MMM-YYYY") & ".xls")
ActiveWorkbook.SaveCopyAs vFilename
Set wbActiveBook = Workbooks.Open(vFilename)
'Now strip all VBA, modules, userforms from the copy
'This code is from Chip Pearson's website http://www.cpearson.com
Set VBComps = wbActiveBook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case vbext_ct_StdModule, vbext_ct_MSForm, vbext_ct_ClassModule
VBComps.Remove VBComp
Case Else
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VBComp
wbActiveBook.Save ' saves new version after code is stripped
ThisWorkbook.Saved = True ' sets save flag to true, does not actually save
Application.Quit ' quits entire application, all workbooks
End Sub
Sorry for the lengthy post, saw other people getting ripped on for not being detailed enough, haha.
This should work for you now , by testing only the last cell being filled in then you will be sure all the data is in before you change them to values
Were basically telling worksheet_calculate to do nothing until the last cell has a formula
NOTE : SEE OP ANSWER BELOW FOR MODIFIED CODE THAT WORKED IN THIS SCADA SITUATION
Private Sub Worksheet_Calculate()
Dim rngLastCell As Range
Set rngLastCell = Range("D52")
If rngLastCell.HasFormula Then
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End If
End Sub
Ended up getting it! Thanks to Steven Martin for giving me a jump off point to get this working, until you you posted your answer I didn't think an if statement would work for me here without a loop.
This is what worked for me:
Private Sub Worksheet_Calculate()
Dim rngLastCell As Range
Set rngLastCell = Range("D52")
If WorksheetFunction.IsNA(rngLastCell) = False Then
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End If
End Sub
And then the same IF statement checking for "#N/A" in the 2nd sheet's code too, works like a charm now.
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question appears to be off-topic because it lacks sufficient information to diagnose the problem. Describe your problem in more detail or include a minimal example in the question itself.
Closed 8 years ago.
Improve this question
I can't post an image so I wanted to explain my question in more detail.
I have 2 files: The vlookup formulas are in the Destination File. The vlookup values are in the Source File. The Destination File will be closed. The Source File will be opened. In the Source File, I may change 15 cell values. If so, I want the 15 cells in the Destination File (closed workbook) to be highlighted yellow as they contain the vlookups when I open it. I hope this explains what we're trying to solve.
UPDATE
Instead of highlighting the cells, do you know how to insert a comment in each cell whenever the cell value changes? I would like to comment to say, "Changed cell from 20 to 30".
Try this code (may be time consuming for big ranges with formulas):
in Code module (standart module):
Public cVals As New Dictionary
Sub populateDict()
Dim rng As Range, c As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = Intersect(.UsedRange, .Range("CP:CV"))
If rng Is Nothing Then Exit Sub
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
End Sub
in ThisWorkbook module:
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
Call populateDict
Application.Calculation = xlCalculationAutomatic
End Sub
in Sheet module:
Private Sub Worksheet_Calculate()
Dim rng As Range, c As Range
Dim rngToColor As Range
On Error GoTo ErrorHandler
Application.EnableEvents = False
'get only used part of the sheet
Set rng = Intersect(Me.UsedRange, Me.Range("CP:CV"))
If rng Is Nothing Then GoTo ExitHere ' if there is no formulas in CP:CV - exit from sub
'reset color for all cells
rng.Interior.Color = xlNone
For Each c In rng
'check if previous value of this cell not equal to current value
If cVals(c.Address) <> c.Text Then
'if so (they're not equal), remember this cell
c.ClearComments
c.AddComment Text:="Changed value from '" & cVals(c.Address) & "' to '" & c.Text & "'"
End If
'store current value of cell in dictionary (with key=cell address)
cVals(c.Address) = c.Text
Next c
ExitHere:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Resume ExitHere
End Sub
Note that I'm uisng Dictionary object. For working with Dictionary object you should add reference to Microsoft Scripting Runtime library. Go to Tools->References and select Microsoft Scripting Runtime library:
It looks like you want to build something similar to a trading platform to highlight cells linked with RTD formulas. If it is true (or even if you make changes manually), you can achieve your goal by using worksheet_change.
The below procedure looks at cells in columns 12 to 15 (the real-time values that change) and it compares the values in the FmlaRng (which I assume is a fixed range) before the calculate occurs and after. It is important you set your sheet as xlCalculateManual otherwise Excel will calculate the new values before you can record the old ones.
Also, I am not sure if you need to keep the Application.EnableEvents, but I left it there.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim endrow As Long, startrow As Long, i As Long, j As Long
Dim PreValue As Variant
Dim FmlaRng As Range
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
If Target.Column >= 12 And Target.Column <= 15 Then 'This is where the cell initally changes (the lookupvalue cells)
On Error GoTo 0
startrow = 1
endrow = 1000
With Workbooks("Workbook2").sheets("Sheet1") 'You need to change these names
Set FmlaRng = .Range(.Cells(startrow, 94), .Cells(endrow, 100)) 'FmlaRng is where the lookups should be
FmlaRng.Cells.Interior.ColorIndex = 0
PreValue = FmlaRng
Calculate 'This is when vlookups update
For i = LBound(PreValue, 1) To UBound(PreValue, 1)
For j = LBound(PreValue, 2) To UBound(PreValue, 2)
If FmlaRng.Cells(i, j) = PreValue(i, j) Then
Else
FmlaRng.Cells(i, j).Interior.ColorIndex = 36
End If
Next j
Next i
End with
End If
Application.EnableEvents = True
End Sub