I want to use the code below without having to write out the sheet name in Sheets("Sheet1").Activate in the Public Sub function, so I can just click on the sheet and run the code. I am unfamiliar with VBA language, and this should be a simple fix, but after an hour of trying things out, I can't get it working so I'm asking here now. Also, when I remove the Sheets("Sheet1").Activate, the abbrev sheet is then activated so the function does not run on that instead of my desired sheet. Any help would be appreciated!
Public gcolWords As New Collection
Public Sub ReplaceAllWrds()
Dim vWord, vAbv, itm
Dim i As Integer
Dim Lastrow As Integer
LoadAbbrevs
Sheets("Sheet1").Activate
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("F" & Lastrow).Select
For Each itm In gcolWords
i = InStr(itm, ":")
vWord = Left(itm, i - 1)
vAbv = Mid(itm, i + 1)
Replace1Wrd vWord, vAbv
Next
Set gcolWords = Nothing
End Sub
Private Sub Replace1Wrd(ByVal pvWrd, pvAbv)
On Error Resume Next
Selection.Replace What:=pvWrd, Replacement:=pvAbv, LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Private Sub LoadAbbrevs()
Dim vWord, vAbv, vItm
Sheets("abbrevs").Activate
Range("A2").Select
While ActiveCell.Value <> ""
vWord = ActiveCell.Offset(0, 0).Value
vAbv = ActiveCell.Offset(0, 1).Value
vItm = vWord & ":" & vAbv
gcolWords.Add vItm
ActiveCell.Offset(1, 0).Select 'next row
Wend
End Sub
You should define a Excel.Worksheet that points to the ActiveSheet, and then use it to keep the reference:
Public Sub ReplaceAllWrds()
Dim vWord, vAbv, itm
Dim i As Integer
Dim Lastrow As Integer
Dim ws As Excel.Worksheet
Set ws = ActiveSheet
LoadAbbrevs
ws.Activate
'MsgBox "The name of the ws sheet is " & ws.Name
Lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range("F" & Lastrow).Select
For Each itm In gcolWords
i = InStr(itm, ":")
vWord = Left(itm, i - 1)
vAbv = Mid(itm, i + 1)
Replace1Wrd vWord, vAbv
Next
Set gcolWords = Nothing
End Sub
As a note, you could review your code using worksheet objects; this way you can operate directly via Worksheet references, and you don't need to activate the sheets when you operate on them.
You do not need to activate the sheet if you're using worksheet objects.
Dim ws As Excel.Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Cells(1,1).Value = "Example"
Using the worksheet objects can speed up your code and you don't need to worry about what sheet is active.
The following is a quick example of what your LoadAbbrevs could be.
Sub Example()
Dim WS as Worksheet
Set WS = ThisWorkbook.Sheets("abbrevs")
Dim RowIndex as Integer
RowIndex = 2
While WS.Cells(RowIndex, 2).Value <> ""
gcolWords.add WS.Cells(RowIndex, 2).Value + ":" + WS.Cells(RowIndex, 3).Value
RowIndex = RowIndex + 1
Wend
End Sub
Related
So I have designed this code to insert new entries into my master Database Log but when I run the code it is much too slow.
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim LR As Long, i As Long, iRow As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
With ws
LR = .Cells(Rows.Count, 1).End(xlUp).Row
If 2 > LR Then Exit Sub
iRow = 3
For i = 1 To LR
If .Cells(i, 1).DisplayFormat.Interior.Color = RGB(217, 230, 251) Then
Worksheets("Call Log").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1).Resize(1, 7).Copy ThisWorkbook.Worksheets("Call Log").Cells(iRow, "A")
End If
Next i
End With
Set ws = Nothing
End Sub
As you can see, my code goes through the range, determines if it matches my criteria (in this case the color of the cell) and then Inserts a row in the destination Worksheet and copies the data into that newly created row over and over until it finishes. I've thought of maybe having it select all of the necessary cells, copy and then insert them all at once into the destination worksheet, but I'm not sure how to go about that.
Any help is greatly appreciated!
One of the things you are doing obsoletely, is copying something to the clipboard, while this is not necessary: instead of
Range("<somewhere>").Copy
Range("<elsewhere>").Paste
You might simply do:
Range("<elsewhere>".Value = Range("<somewhere>").Value
It's always a good idea to turn off screen updating and set calculations to manual (unless you need it)
Application.SceenUpdating = false
Application.calculations = xlmanual
Then set them back to true and xlautomatic at the end of the code.
Not sure if the syntaxes is correct, I'm typing from my phone
If you absolutely need to copy the source formatting of the cells also, then you could use a filter and then copy only the visible cells, all in one go. Something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
Dim filterColor As Long
'
'Filter Range
filterColor = RGB(217, 230, 251)
With Range(shtData.Cells(1, 1), shtData.Cells(lastRow, 1))
.AutoFilter Field:=1, Criteria1:=filterColor, Operator:=xlFilterCellColor
End With
'
Dim rng As Range
Const lastCol As Long = 7
Dim firstRow As Long
'
'Get filtered range
'First row remains visible regardless of filter. Check it
If shtData.Cells(1, 1).Cells(1, 1).DisplayFormat.Interior.Color <> filterColor Then
firstRow = 2
Else
firstRow = 1
End If
On Error Resume Next
Set rng = Range(shtData.Cells(firstRow, 1), shtData.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Nothing meets criteria
'
Dim tempArea As Range
Dim rCount As Long
'
'Get required rows count
For Each tempArea In rng.Areas
rCount = rCount + tempArea.Rows.Count
Next tempArea
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + rCount - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Copy shtLog.Cells(iRow, 1)
'
'Remove filter
rng.AutoFilter
End Sub
But, if you don't care about source formatting then you could use something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
'Read data in array (super fast)
Dim rng As Range
Dim arrData() As Variant
Const lastCol As Long = 7
'
Set rng = Range(shtData.Cells(1, 1), shtData.Cells(lastRow, lastCol))
arrData = rng.Value2
'
'Store relevant row numbers
Dim collRows As New Collection
Dim i As Long
Dim filterColor As Long: filterColor = RGB(217, 230, 251)
'
For i = LBound(arrData) To UBound(arrData)
If rng.Cells(i, 1).DisplayFormat.Interior.Color = filterColor Then
collRows.Add i
End If
'
'I am not a fan of using colors for filtering. It's much faster to have a separate
' column (indicator column) that can be used for that. This way we could do
' something like: If arrData(i, indCol) = expectedValue Then ...
' which is much faster than accesing cells
Next i
'
'Prepare data for writing
Dim arrFiltered() As Variant
ReDim arrFiltered(1 To collRows.Count, 1 To lastCol)
Dim r As Variant
Dim c As Long
'
i = 0
For Each r In collRows
i = i + 1
For c = 1 To lastCol
arrFiltered(i, c) = arrData(r, c)
Next c
Next r
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + collRows.Count - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
'Write
With Range(shtLog.Cells(iRow, 1), shtLog.Cells(iRow + collRows.Count - 1, lastCol))
.Value2 = arrFiltered
End With
End Sub
Private Function GetWorksheet(ByVal sheetName As String, ByVal book As Workbook) As Worksheet
On Error Resume Next
Set GetWorksheet = book.Worksheets(sheetName)
On Error GoTo 0
End Function
The above is rushed code but proves some ways of doing the task. Other things that need to be considered are:
Are the worksheets protected? if yes, filtering and inserting rows can be an issue
Inserting rows will fail if the rows are intersecting multiple dynamic tables (listobjects)
Code needs to be changed if data doesn't start on row 1 in the source
and probably others that don't come to mind right now
I may have up to 8 unique values in column D. I am looking for a code that will copy & paste each row with unique value to a new sheet.
So I may have up to 8 new sheets.
Could you help me to build the code that will do that?
This is what I have so far:
Option Explicit
Sub AddInstructorSheets()
Dim LastRow As Long, r As Long, iName As String
Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
Dim i As Integer
Dim m As Integer
'set objects
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set ts = Sheets("Master")
'set last row of instructor names
LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
'add instructor sheets
On Error GoTo err
Application.ScreenUpdating = False
For r = 17 To LastRow 'assumes there is a header
iName = ws.Cells(r, 4).Value
With wb 'add new sheet
ts.Copy After:=.Sheets(.Sheets.Count) 'add template
Set nws = .Sheets(.Sheets.Count)
nws.Name = iName
Worksheets(iName).Rows("17:22").Delete
Worksheets("Master").Activate
Range(Cells(r, 2), Cells(r, 16)).Select
Selection.Copy
m = Worksheets(iName).Range("A15").End(xlDown).Row
Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
Next r
err:
ws.Activate
Application.ScreenUpdating = True
End Sub
The thing is that this macro is creating new sheets, which is not necessary. I only want to make following.
If you find a unique value in column D (which will have exact name as other sheet), find this sheet and paste whole row in there.
Sub CopyFromColumnD()
Dim key As Variant
Dim obj As Object
Dim i As Integer, lng As Long, j As Long
Dim sht As Worksheet, mainsht As Worksheet
Set obj = CreateObject("System.Collections.ArrayList")
Set mainsht = ActiveSheet
With mainsht
lng = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("D1", .Range("D" & lng))
For Each key In .Value
If Not obj.Contains(key) Then obj.Add key
Next
End With
End With
For i = 0 To obj.Count - 1
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = obj(i)
For j = 1 To lng
If mainsht.Cells(j, 4).Value = obj(i) Then
mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
Exit For
End If
Next
Next
End Sub
Ok, I did the workaround. I have created a list of unique values in a separate sheet.
Sub copypaste()
Dim i As Integer
Dim j As Integer
LastRow = Worksheets("Master").Range("D17").End(xlDown).Row
For i = 17 To LastRow
For j = 2 To 10
Workstream = Worksheets("Database").Cells(j, 5).Value
Worksheets("Master").Activate
If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
Range(Cells(i, 2), Cells(i, 16)).Select
Selection.Copy
Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Else
End If
Next j
Next i
End Sub
Thank you everyone for help and your time!
I am trying to make a command button copy data from the main sheet "all" into 4 different sheets based on wether or not they meet the requirement. i have made it work with my "Lending" with the code bellow, but in the next 3 columns i have the data "FX" "Account" and "Payments" and i would like to have this one command button work with all of the sheets. Some of the dato points will go into multiple sheets, while some would only live up to 1 of them. Anyone who knows how i can expand the code to make it work?
Private Sub CommandButton1_Click()
Dim AllSheet As Worksheet
Dim LendSheet As Worksheet
Dim LastRow As Integer
Dim RowCnt As Integer
Dim DestRow As Integer
Set AllSheet = ActiveWorkbook.Sheets("All")
Set LendSheet = ActiveWorkbook.Sheets("Lending")
With AllSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
DestRow = LendSheet.Range("A" & LendSheet.Rows.Count).End(xlUp).Row + 1
For RowCnt = 2 To LastRow
If .Cells(RowCnt, 3).Value = "X" Or .Cells(RowCnt, 3).Value = "x" Then
LendSheet.Rows(DestRow).Value = .Rows(RowCnt).Value
DestRow = DestRow + 1
End If
Next
End With
'..... Remove Duplicates
Dim LastCol As String
With LendSheet
LastCol = Split(.Range("A1").End(xlToRight).Address, "$")(1)
.Range("A:" & LastCol).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7),
Header:=xlYes
End With
End Sub
The "copy data to another sheet" can be split out into a separate sub, and that cleans up your main code, making it easier to add new checks.
Private Sub CommandButton1_Click()
Dim AllSheet As Worksheet
Dim LastRow As Long
Dim RowNum As Long
Set AllSheet = ActiveWorkbook.Sheets("All")
With AllSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For RowNum = 2 To LastRow
If UCase(.Cells(RowNum, 3).Value) = "X" Then
AppendRow .Rows(RowNum), "Lending"
End If
If UCase(.Cells(RowNum, 4).Value) = "BLAH" Then
AppendRow .Rows(RowNum), "FX"
AppendRow .Rows(RowNum), "Account" '<< can copy to >1 sheet...
End If
Next
End With
'..... Remove Duplicates
End Sub
'append a range to a named sheet
Sub AppendRow(rwSrc As Range, shtName As String)
Dim rw As Range
Set c = ActiveWorkbook.Sheets(shtName).Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).Resize(1, rwSrc.Columns.Count)
'make sure we're really copying to a blank row...
Do While Application.CountA(rw) > 0
Set rw = rw.Offset(1, 0)
Loop
rw.Value = rwSrc.Value
End Sub
I want to insert a column to the right if string"P018" is present in the third row of the sheet:
My code is :
Sub Insrt()
Dim Found As Range
Dim LR As Long
Dim I As Integer
I = 1
Do While Cells(4, I).Value <> ""
'If Cells(3, I).Value = "P018" Then
Set Found = Cells(3, I).Find(what:="P018", LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then GoTo Label
Found.Offset(, 1).EntireColumn.Insert
Label:
Loop
End Sub
This going in an endless loop.
You want to use a standard for loop that loops backwards:
Sub insert()
Dim ws As Worksheet
Dim lastColumn As Long
Dim i As Long
Set ws = ActiveSheet
With ws
lastColumn = .Cells(4, .Columns.Count).End(xlToLeft).Column
For i = lastColumn To 1 Step -1
If .Cells(3, i) = "P018" Then Columns(i + 1).insert
Next i
End With
End Sub
I have the following Macro:
Sub Remove_Junk_Data()
Call Open_Workbook
Call Scrub_Master
Call Scrub_Change_History
Call Scrub_Update
Call Scrub_ExistingOwnership
Call Save_Scrubbed
End Sub
Sub Open_Workbook()
Workbooks.Open "https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx"
Workbooks("tooloutput.xlsx").Activate
End Sub
Sub Scrub_Master()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Master").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_Change_History()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Change History").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_Update()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("Update").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Scrub_ExistingOwnership()
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
Sheets("ExistingOwnership").Select
For i = LastRow To 1 Step -1
Set r = Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End Sub
Sub Save_Scrubbed()
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = False
Workbooks("Master_FM_Update.xlsx").Close
End Sub
If I comment out the "Open_Workbook" sub and manually open the workbook then run the remainder of Remove_Junk_Data(), it works perfectly.
If I try to run Remove_Junk_Data with Open_Workbook active, then no errors are thrown, but the 4 middle subs dont do anything...
Has anyone ran into anything like this? Did you find a resolution? I want to click a button and have all 6 subs do their thing correctly...
Edit: With input, new macro, and it works! Thanks guys!:
Sub Remove_Junk_Data()
Workbooks.Open "https://company.sharepoint.com/sites/project/subproject/subsubproject/Subsubprojecttool/tooloutput/tooloutput.xlsx"
Dim myValue As String
Dim LastRow As Long
Dim i As Long
Dim r As Range
With Workbooks("tooloutput.xlsx").Sheets("Master")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("Change History")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("Update")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
With Workbooks("tooloutput.xlsx").Sheets("ExistingOwnership")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myValue = ""
For i = LastRow To 1 Step -1
Set r = .Cells(i, 1)
If r.Value = myValue Then r.EntireRow.Delete
Next i
End With
End Sub
I have done some changes to your code, the comments in the procedure intent to explain the changes. My advice is that besides what you are getting from sites like Stackoverflow you should also read the corresponding documentation to achieve a deeper understanding of the concepts and resources used. Nevertheless, do not hesitate to ask question as you go forward in developing your programing skills.
The code below consolidates all what you are trying to do in one procedure, there you'll see how to run repetitive code for a series of values (i.e. worksheets in this case)
Suggest to visit the following pages:
Variables & Constants, Application Object (Excel), Excel Objects
With Statement, For...Next Statement, For Each...Next Statement,
If...Then...Else Statement
Worksheets Object (Excel), Worksheet Object (Excel), Range Object (Excel)
Sub Remove_Junk_Data()
Rem Use an Array Variable to List all the worksheets you want to work with
Dim aWsh As Variant, vItm As Variant
aWsh = Array("Master", "Change History", "Update", "ExistingOwnership")
Rem Declare Object Variables
Dim Wbk As Workbook
Dim Wsh As Worksheet
Dim lRowLst As Long
Dim lRow As Long
Rem Open Workbook & Set Workbook Object Variable
Set Wbk = Workbooks.Open("https://company.sharepoint.com/sites/project/subproject/subsubproject/subsubprojecttool/tooloutput/tooloutput.xlsx")
Rem Loop throught the worksheet list and process each one
For Each vItm In aWsh
Rem Set Worksheet Object Variable
Set Wsh = Wbk.Worksheets(vItm)
With Wsh
lRowLst = Cells(Rows.Count, "A").End(xlUp).Row
For lRow = lRowLst To 1 Step -1
With .Cells(lRow, 1)
If .Value2 = Empty And Not (.HasFormula) Then .EntireRow.Delete
End With: Next: End With: Next
Application.DisplayAlerts = False
Wbk.Save
Application.DisplayAlerts = True
Workbooks("Master_FM_Update.xlsx").Close
End Sub