I have attempted to add functionality to an excel add-in ave been developing which trims the leading spaces at the end of used cells, and maybe even parse the text, The reason I need to do this is simply to have it turn into a hyperlink which I have already working but that parts fine.
This is what I have attempted so far, I have it trimming the active.worksheet am on which is fine but I can't figure out how to:
Trim Every cell being used across the whole workbook.
And also parse the text if possible
This is my attempt at Trimming the entire workbook, Its something simple I just know it, I just cant figure it out:
Sub DoTrim(Wb As Workbook)
Dim cell As Range
Dim str As String
Dim nAscii As Integer
Dim wsh As Worksheet
For Each wsh In Worksheets
With wsh.UsedRange
For Each cell In ActiveSheet.UsedRange
str = Trim(cell)
If Len(str) > 0 Then
nAscii = Asc(Left(str, 1))
If nAscii < 33 Or nAscii = 160 Then
If Len(str) > 1 Then
str = Right(str, Len(str) - 1)
Else
str = ""
End If
End If
End If
cell = str
Next cell
End With
Next wsh
End Sub
Any advice would be welcome am fairly new to this Language so sorry if I sound like a complete Newb!
TL;DR Trims cells only worksheet am on, needs to run across whole workbook I cant figure out how to iterate it across the whole thing.
EDIT: Is that also a quicker way of trimming these cells, the spreadsheets that are created for whom am designing this are massive and takes a while to trim the cells at times
Try this
Sub DoTrim(Wb As Workbook)
Dim aCell As Range
Dim wsh As Worksheet
'~~> If you are using it in an Add-In, it is advisable
'~~> to keep the user posted :)
Application.StatusBar = "Processing Worksheets... Please do not disturb..."
DoEvents
Application.ScreenUpdating = False
For Each wsh In Wb.Worksheets
With wsh
Application.StatusBar = "Processing Worksheet " & _
.Name & ". Please do not disturb..."
DoEvents
For Each aCell In .UsedRange
If Not aCell.Value = "" And aCell.HasFormula = False Then
With aCell
.Value = Replace(.Value, Chr(160), "")
.Value = Application.WorksheetFunction.Clean(.Value)
.Value = Trim(.Value)
End With
End If
Next aCell
End With
Next wsh
Application.ScreenUpdating = True
Application.StatusBar = "Done"
End Sub
I agree with Siddarth:
For Each cell In ActiveSheet.UsedRange
Should be:
For Each cell In wsh.UsedRange
I would have thought you should be able to remove with 'With wsh.UsedRange' statement around the loop as well.
As you are passing in a WorkBook reference, perhaps you should consider changin your outer For loop from:
For Each wsh In Worksheets
to:
For Each wsh In Wb.Worksheets
Related
I have over 20 sheets with VBA codes that performs calculations realtime and simultaneously. All the calculations on each sheet are working fine except some COUNTIF and FIND ADDRESS function whereby VBA ignores running them on every other sheet unless I'm active on that sheet, then it works.
I have tried several methods and this one works by activating all the sheets from another sub
Worksheets("Sheet2").activate
Worksheets("Sheet3").activate
Worksheets("Sheet4").activate
By doing this, the COUNTIF and FIND ADDRESS functions works on all sheets however, it's flickering through all of the sheets. I was also able to get it to stop on one sheet by adding (Worksheets("Sheet1").activate) at the end of the last sub. This doesn't fix the issue as I am unable to check any other sheet. I also tried
Application.ScreenUpdating = False 'At the beginning of the sub
Application.ScreenUpdating = True 'At the end of the sub
No luck. Tried wrapping each code in the vba around
Dim ws As Worksheets
ws.activate
Doesn't fix the issue. How can I activate all sheets without flickering through them? If activating them all at once can't fix the issue, is there another way? Thank you
Here is the sample of the code -
psup = "Generated" & " " & lBar
If Abs(sp2) = 0 Then
If Cells.Find(psup).Offset(-8, 0).Value > 3 Or Cells(b + 1, h).Offset(-8, 0).Value > 3 Then
Call allNewYes
'Cells(b - 7, h).Value = Cells(b - 7, h).Value + 4
sp2 = 1
End If
End If
'1.Get Position - Generated
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 2 Then
sp6 = Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) - 1
Call spLocation
Else
If Application.WorksheetFunction.CountIf(ActiveSheet.Cells, psup) > 0 Then
sp5 = Cells.Find(psup).Address
End If
End If
Sub allNewYes()
Dim locazion As String
Dim FindValue As String
FindValue = psup
Dim FindRng As Range
Set FindRng = Cells.Find(What:=FindValue)
Dim FirstCell As String
FirstCell = FindRng.Address
Do
locazion = FindRng.Address
Range(locazion).Offset(-8, 0).Value = Abs(Range(locazion).Offset(-8, 0).Value) + 4
Set FindRng = Cells.FindNext(FindRng)
Loop While FirstCell <> FindRng.Address
End Sub
Here is a mock-up of how you perform actions on multiple worksheets, without selecting or activating them - using part of your code as an example. I wasn't sure how you create FindValue - so you'd have to do that part yourself.
Sub perform_actions_on_all_sheets()
Dim wb As Workbook, ws As Worksheet, FindRng As Range, FirstCell As String
FindValue = 5 'change this to something appropriate
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name <> "ExcludeThisWorksheetName" Then
'do stuff to ws, e.g.
Set FindRng = ws.Cells.Find(What:=FindValue)
If Not (FindRng Is Nothing) Then
FirstCell = FindRng.Address
Do
FindRng.Offset(-8, 0).Value = Abs(FindRng.Offset(-8, 0).Value) + 4
Set FindRng = ws.Cells.Find(FindValue, LookIn:=xlValues, LookAt:=xlWhole)
Loop While FirstCell <> FindRng.Address
End If
End If
Next
End Sub
The If ws.Name <> "ExcludeThisWorksheetName" Then ... End If is optional - this is usually required if you want to run the script on every tab except one.
For anyone experiencing similar issues, by removing (ActiveSheet.Cells) in my code fixed the issue
I'm incredibly new to VBA, and drafted out a bit of code to replace some portions of hyperlinks. It works great, but now I can't seem to figure out how to make it run over the whole workbook. Here's what I've got:
For Each cell In Range("C13")
If cell.Hyperlinks.Count > 0 Then
If InStr(cell.Hyperlinks(1).Address, original) <> 0 Then
temp = final & Mid(cell.Hyperlinks(1).Address, Len(original) + 1)
cell.Hyperlinks(1).Address = temp
End If
End If
Next cell
End Sub
Right now I just used range("C13") as a test, but ideally it would say something like application.workbooks(1) (but of course that doesn't work). Any ideas? Thanks!
Try:
For Each wb In Application.Workbooks
For Each ws In wb.Worksheets
For Each cell In ws.UsedRange
(your code)
Next cell
Next ws
Next wb
Working for me using cell.Value = cell.Value + 1 with multiple workbooks/sheets as a simple test.
It seems you are after code to look at the hyperlinks in a workbook
Dim hLink As Hyperlink
Dim iSh As Worksheet
For Each iSh In ThisWorkbook.Worksheets
For Each hLink In iSh.Hyperlinks
' Your code adapted a little bit
If InStr(hLink.Address, original) <> 0 Then
temp = Final & Mid(hLink.Address, Len(original) + 1)
hLink.Address = temp
End If
' End of your code
Next
Next
I duplicate a report and rename the tab as per user input.
I need to take that user input and insert it into a formula which would then be placed into a cell. Over time (monthly) the formula would need to change columns.
Below is what I have done so far.
sName is the user defined input, I think I have declared it as a global variable correctly
sName is used in SPVCLookup as the name of the tab (not working)
sName is used in countif as part of a formula (not working)
' will copy SPC Report to new tab and ask user to name the tab
Dim sName As String
Sub CopyRename()
'Dim sName As String
Dim wks As Worksheet
Worksheets("SPC Report").Copy after:=Sheets(Worksheets.Count)
Set wks = ActiveSheet
Do While sName <> wks.Name
sName = Application.InputBox _
(Prompt:="Enter new worksheet name")
On Error Resume Next
wks.Name = sName
On Error GoTo 0
Loop
Set wks = Nothing
End Sub
'------------------------
Sub CreateDA()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Departmental Analysis"
End With
End Sub
'------------------------
Sub SPCVlookup()
'Sheets("sName").Select 'this needs to be user defined
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=VLOOKUP(D2,'Card Exchange'!$A$1:$V$218,6,FALSE)"
End Sub
Sub Countif()
Sheets("Departmental Analysis").Select
' I think I need a for loop to cycle through the range columns
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=COUNTIFS('sname'!$A$1:$E$12104,A3)"
End Sub
You've got two problems here.
Sub SPCVlookup()
Sheets("sName").Select 'selects the sheet called "sName"
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=VLOOKUP(D2,'Card Exchange'!$A$1:$V$218,6,FALSE)"
End Sub
This code selects the sheet called "sName". Remove the "" marks:
Sub SPCVlookup()
Sheets("sName").Select 'selects the sheet called "sName"
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=VLOOKUP(D2,'Card Exchange'!$A$1:$V$218,6,FALSE)"
End Sub
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=COUNTIFS('sname'!$A$1:$E$12104,A3)"
This is a bit trickier. You'll need to copy sName into the formula, but in order to do so you'll need to escape it (just in case sName contains quotes). You can do that by doubling each quote:
Replace(sName, """", """"&"""")
So...
Range(Range("E2"), Range("E2").End(xlDown)).Formula = "=COUNTIFS('" & Replace(sName, """", """"&"""") & "'!$A$1:$E$12104,A3)"
This won't update the cells when sName changes; to do that, you'll need to set a spreadsheet name. Variables in VBA and Formulas aren't shared.
I have hundreds of Columns in excel that I don't need. I have a range that I want to keep.
At the minute I have
Sub DeleteClms ()
Range("A:G,L:O").Delete
End Sub
Is there anyway to make this an opposite, in other languages I would simply put a =!.
I have tried putting <> in but I dont know where/how to put it into my code?
Thanks
There is no Excel or VBA function for the Symetric Difference of the columns that I know of.
Here is a quick VBA function to get there. Usage would be DeleteAllBut Range("A:C,H:Q")
Sub DeleteAllBut(rngToKeep As Range)
Dim ws As Worksheet
Dim rngToDelete As Range
Dim rngColi As Range
'Number of columns used in worksheet
Set ws = rngToKeep.Parent
iCols = ws.UsedRange.Columns.Count
FirstOne = True
For i = 1 To iCols
Set rngColi = Range("A:A").Offset(0, i - 1)
If Intersect(rngToKeep, rngColi) Is Nothing Then
If FirstOne Then
Set rngToDelete = rngColi
FirstOne = False
Else
Set rngToDelete = Union(rngColi, rngToDelete)
End If
End If
Next i
Debug.Print rngToDelete.Address & " was deleted from " & ws.Name
rngToDelete.Delete
End Sub
This question already has answers here:
Can I Get the Source Range Of Excel Clipboard Data?
(3 answers)
Closed 2 years ago.
I know about Application.CutCopyMode, but that only returns the state of the CutCopyMode (False, xlCopy, or xlCut).
How do I return the address of the currently copied range in Excel using VBA? I don't need the currently selected range (which is Application.Selection.Address). I need the address of the range of cells with the moving border (marching ants) around it.
In other words, if you select a range of cells, hit CTRL+C, and then move the selection to another cell, I need the address of the cells that were selected when the user hit CTRL+C.
Thanks!
As far as I know you can't do that with vba. You can however code your own copy sub and store the source in a global variable.
Something like this:
Option Explicit
Dim myClipboard As Range
Public Sub toClipboard(Optional source As Range = Nothing)
If source Is Nothing Then Set source = Selection
source.Copy
Set myClipboard = source
End Sub
10 years later you still can't refer directly to a copied Range
(shown by the "marching ants border" aka "dancing border", "moving border").
But you can get its address by copying the cells as link to a temporary worksheet. There you can collect the desired range's address.
Private Sub ThereAreTheMarchingAnts()
Dim rngCopied As Range ' the copied range with the marching ants border
Dim rngSelected As Range ' the selected range
Dim tmpWorksheet As Worksheet ' a temporary worksheet
Dim c As Range ' a cell for looping
' Exit, if nothing was copied (no marching ants border):
If Not (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then Exit Sub
' Exit, if no range is selected (just for demonstration)
If Not TypeName(Selection) = "Range" Then Exit Sub
' remember selected Range:
Set rngSelected = Selection
' add a temporary sheet and paste copied cells as link:
Set tmpWorksheet = ActiveWorkbook.Sheets.Add
tmpWorksheet.Paste link:=True
' go through all pasted cells and get the linked range from their formula:
For Each c In tmpWorksheet.UsedRange
If rngCopied Is Nothing Then
Set rngCopied = Range(Mid(c.Formula, 2))
Else
Set rngCopied = Union(rngCopied, Range(Mid(c.Formula, 2)))
End If
Next c
' delete the temporary worksheet without asking:
Application.DisplayAlerts = False
tmpWorksheet.Delete
Application.DisplayAlerts = True
' show the addresses:
MsgBox "Copied Range: " & rngCopied.Address(0, 0, xlA1, True) & vbLf & _
"Selected Range: " & rngSelected.Address(0, 0, xlA1, True)
End Sub
The code also works with multiranges and also if the copied range and the selected range are on different sheets.
When you copy a Range, the address is copied to the Clipboard along with other formats. You can check that with Clipboard Viewer application.
So if you need the copied Range, get it from Clipboard. It will be something like> $A2:$B5 or similar
The only way i can think of doing this is tracking the last range selected with a global variable and then waiting until you think a copy action is done. Unfortunately neither is easy.
The following is a quick attempt that has two problems;
If you copy the same data twice it
isn't updated
If a copy or paste is
fired from another app, the results
may vary.
This is one of those last hope tricks when tracking events that don't really exist. Hope this helps.
''# Add a reference to : FM20.dll or Microsoft Forms 2.0
''# Some more details at http://www.cpearson.com/excel/Clipboard.aspx
Option Explicit
Dim pSelSheet As String
Dim pSelRange As String
Dim gCopySheet As String
Dim gCopyRange As String
Dim gCount As Long
Dim prevCBText As String
Dim DataObj As New MSForms.DataObject
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
CopyTest
pSelSheet = Sh.Name
pSelRange = Target.Address
''# This is only so you can see it working
gCount = gCount + 1
application.StatusBar = gCopySheet & ":" & gCopyRange & ", Count: " & gCount
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
CopyTest ''# You may need to call CopyTest from other events as well.
''# This is only so you can see it working
gCount = gCount + 1
application.StatusBar = gCopySheet & ":" & gCopyRange & ", Count: " & gCount
End Sub
Sub CopyTest()
Dim curCBText As String
Dim r As Range
DataObj.GetFromClipboard
On Error GoTo NoCBData
curCBText = DataObj.GetText
On Error Resume Next
''# Really need to test the current cells values
''# and compare as well. If identical may have to
''# update the gCopyRange etc.
If curCBText <> prevCBText Then
gCopySheet = pSelSheet
gCopyRange = pSelRange
prevCBText = curCBText
End If
Exit Sub
NoCBData:
gCopySheet = ""
gCopyRange = ""
prevCBText = ""
End Sub
Oh and excuse the wierd comments ''# they're just there to help the syntax highlighter of SO.
I think you can use this method
https://learn.microsoft.com/en-us/office/vba/api/Excel.Application.OnKey
This method assigns a function to the hot key Ctrl+C, every time this combination is used, the function will be triggered and you can get the address of the range.