So I have some code that comments on cells based on information beside of it and it is working almost flawlessly. However, I am having an issue where it is working on all sheets in the entire workbook instead of just sheet 3 like it is supposed to. I have this code set up on sheet 3 only in the VBA projects. So my question is how would I make this work only on one single sheet?
Here is my code
Private Sub Worksheet_Calculate()
ActiveSheet.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Application.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False
cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
However, I am having an issue where it is working on all sheets in the entire workbook
That's because you've coded it to work on the ActiveSheet
To refer to the sheet the event is coded in, use Me
Private Sub Worksheet_Calculate()
Me.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Me.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
End Sub
Related
I'm trying to take a part number from one sheet, find it in another sheet, then for the cells that correspond to tomorrow's date copy the quantity of parts for that specific part number plus two weeks out which is the resize. The code is starting to get really messy and I'm getting confused as to why it's not working. Currently I'm getting an error on cilrow = cil.rows with a mismatch.
Dim cel As Range
Dim cul As Range
Dim cil As Range
Dim cilrow As Long
Dim culcol As Long
Dim wkbOrig As Workbook
Dim wkbShape As Workbook
Dim shtShape As Worksheet
Set wkbOrig = ThisWorkbook
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14")
For Each cil In shtShape.Range("H6:H11")
If Left(cel, 10) = cil.Value Then
cilrow = cil.Rows
For Each cul In shtShape.Range("5:5")
If cul.Value = Date + 1 Then
culcol = cul.Column
Range(Cells(cilrow, culcol)).Resize(, 14).Copy
End If
Next
End If
Next
Next
You can do less looping if you use Match().
Untested:
Sub Tester()
Dim cel As Range, wkbShape As Workbook, shtShape As Worksheet
Dim wkbOrig As Workbook, dateCol As Variant, matchRow As Variant
Dim rngSrch As Range
Set wkbOrig = ThisWorkbook
'best to include the file extension in the workbook name...
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & _
WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
'try to match the date...
dateCol = Application.Match(CLng(Date + 1), shtShape.Rows(5), 0)
If IsError(dateCol) Then 'date not matched?
MsgBox "Tomorrow's date not found on Row6 of " & shtShape.Name, vbExclamation
Exit Sub
End If
Set rngSrch = shtShape.Range("H6:H11")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14").Cells
matchRow = Application.Match(Left(cel.Value, 10), rngSrch, 0)
If Not IsError(matchRow) Then
rngSrch.Cells(matchRow).EntireRow.Cells(dateCol).Resize(1, 14).Copy 'to where ?
End If
Next
End Sub
I am trying to figure out simple code to make picture objects visible if particular cells contain data. Cells in range R12:R61 contains objects (pictures, ie. Round Rectangles) that are not visible (.visible = false).
If some cells in range P12:P61 contains data then corresponding hidden image in range R12:R61 of that row need to be visible. I've tried something like this:
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Set xRg = Range("R12:R61")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Visible = True
Next
I'm stuck with this one.
Let's imagine our input looking like this:
Then, working with Range("A1:B10"), the only picture that should be present is the one in rows 1 and 2, as for the other 3 there are numbers in column "A":
Sub TestMe()
Dim checkRange As Range
Dim myPic As Picture
With ActiveSheet
Set checkRange = .Range("A1:B10")
Dim myRow As Range
For Each myRow In checkRange.Rows
If WorksheetFunction.Count(myRow.Cells) > 0 Then
For Each myPic In .Pictures
Debug.Print myPic.TopLeftCell.Address
Debug.Print myPic.BottomRightCell.Address
Dim picRange As Range
Set picRange = .Range(.Cells(myPic.TopLeftCell.Row, myPic.TopLeftCell.Column), _
.Cells(myPic.BottomRightCell.Row, myPic.BottomRightCell.Column))
Debug.Print picRange.Address
If Not Intersect(picRange, myRow) Is Nothing Then
myPic.Visible = False
End If
Next
End If
Next
End With
End Sub
The following code is the one that I'm trying to work with, but I still can't make it work with merge rows. The main idea is to create a loop to check each row from D1:D150 and if the criteria are met then copy the entire row.
This is how my data looks like
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
'------------------------------
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
'Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("D1:D150")
'Set aCell2 = ActiveWorkbook.Sheets("Contract Attributes").Range("D:D").Find("Current Modifications", LookIn:=xlValues)
'--------------------------------------------------------------------
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Cel.MergeArea.Select
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + 1
End If
Next Cel
'--------------------------------------------------------------------
'ws0.Columns(4).Delete
'aCell2.Select
'ActiveCell.EntireRow.Copy
'Sheets("ReviewerTab").Range("A5").Insert
End Sub
TIPS
To begin with, I would recommend that you see How to avoid using Select in Excel VBA. Next you need to identify the range object that you need to copy and then copy them across.
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range You need to declare them explicitly else the first four objects are declared as Variant and not Range. For example Dim Cel As Range, aCell1 As Range, aCell2 As Range, aCell3 As Range, aCellAsses As Range
Do not copy the rows in a loop. It will be slow. Identify the rows you want to copy and then copy them in one go. Below is an example
SAMPLE SCENARIO
To demonstrate how this works, I am taking the below sample.
CODE
I have come up with a basic code. I have commented it so you should not have a problem understanding it. But if you do then feel free to ask :).
Option Explicit
Sub Sample()
Dim wsInput As Worksheet
Dim wsOuput As Worksheet
Dim RangeToCopy As Range
Dim lRow As Long, i As Long, num As Long
Dim searchText As Variant
'~~> Row in output sheet where the rows will be copied
num = 5
'~~> Set your input and output sheets
Set wsInput = ThisWorkbook.Sheets("Contract Attributes")
Set wsOuput = ThisWorkbook.Sheets("ReviewerTab")
'~~> Take the input from the user
searchText = InputBox("Which contract modification would you like to review?")
If Len(Trim(searchText)) = 0 Then Exit Sub
With wsInput
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells and check for criteria
For i = 1 To lRow
If InStr(1, .Range("A" & i).Value2, searchText, vbTextCompare) Then
'~~> identify the rows you need to copy and store them
'~~> in a range object
If RangeToCopy Is Nothing Then
Set RangeToCopy = .Range("A" & i).MergeArea.EntireRow
Else
Set RangeToCopy = Union(RangeToCopy, .Range("A" & i).MergeArea.EntireRow)
End If
End If
Next i
End With
'~~> Copy them across. You can insert them as well
If Not RangeToCopy Is Nothing Then
RangeToCopy.Copy wsOuput.Rows(num)
End If
End Sub
IN ACTION
You need to include the merge area before "Select".
After you copy the rows, you need to count how many merged rows in the copy. I add a new variable num2 to do so. The loop cannot just simply num=num+1, it varies from what rows copied.
You may try the below code.
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
Dim num2 As Integer
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Range(Cells(Cel.Row, 1), Cells(Cel.Row, Cells(Cel.Row, Columns.Count).End(xlToLeft).Column)).Select
num2 = Selection.Rows.Count
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + num2
End If
Next Cel
End Sub
I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub
https://dl.dropbox.com/u/3327208/Excel/copydown.xlsx
This is the sheet if you can't view dropbox.
This is the workbook. What I'm looking to do is where it shows 3M, copy the title of the company down to where it shows Total in Column A, and do the same with the next company.
How do I do this in Excel VBA? I know I can use the last row, but it's not exactly the best way for this I believe, because the original version will have over 300 different companies.
Here is the original code I am using for now. Without the extra bits added in.
Option Explicit
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet 'Import
Dim wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet 'Shipped
Dim wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet 'Issued
Dim Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
wsIMP.Range("E6").Cut wsIMP.Range("E5")
wsIMP.Range("B7:G7").Delete xlShiftUp
End Sub
Matt, I had a great function for this a few months back, but I forgot to copy into my library. However, I've done a pretty good mock-up of what I had before. (I was using it to fill down entries in a pivot table for some reason or other).
Anyway, here it is. You may need to tweak it to meet your exact needs, and I am not claiming it's not prone to any errors at the moment, but it should be a great start.
EDIT = I've updated my code post to integrate into yours to make it easier for you.
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet, wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet, wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet, Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
.Range("E6").Cut .Range("E5")
.Range("B7:G7").Delete xlShiftUp
Call FillDown(.Range("A1"), "B")
'-> more code here
End With
End Sub
Sub FillDown(begRng As Range, col As String)
Dim rowLast As Long, rngStart As Range, rngEnd As Range
rowLast = Range(col & Rows.Count).End(xlUp).Row
Set rngStart = begRng
Do
If rngStart.End(xlDown).Row < rowLast Then
Set rngEnd = rngStart.End(xlDown).Offset(-1)
Else
Set rngEnd = Cells(rowLast, rngStart.Column)
End If
Range(rngStart, rngEnd).FillDown
Set rngStart = rngStart.End(xlDown)
Loop Until rngStart.Row = rowLast
End Sub
enter code here
As long as there are no formulas you don't want to overwrite...
EDIT - updated to set original range based off end of column B
Sub Macro1()
Dim sht as WorkSheet
Set sht = ActiveSheet
With sht.Range(sht.Range("A7"), _
sht.Cells(Rows.Count, 2).End(xlUp).Offset(0, -1))
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub