I'm trying to loop through column A- "Domains", and get total pages per domain. For each row, if the domain is the same, count the total. Once you get to a new domain, put that final page count in the top right box of the domain in Column C.
I'm new to VBA- I'm trying something like this. Any guidance would be appreciated.
Sub TestScript()
iMaxRow = 11000
Range("B1").Select
pagesCounter = 0 'loop counter for each page in site
countEntryCell = 1 'where you put the total # pages for that site
For iRow = 1 To iMaxRow
'loop through column B, while domain name is the same... count rows
'then put final count in count column
If ActiveCell = ActiveCell.Offset(-1, 0) Then
pagesCounter = pagesCounter + 1
Else
'Copy pages count to column c within the box
End If
ActiveCell.Offset(1, 0).Select 'select next row
Next iRow
End Sub
UPD:
Try this one:
Sub TestScript()
Dim lastrow As Long
Dim rng As Range, c As Range
'change Sheet1 to suit
With ThisWorkbook.Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & lastrow)
For Each c In rng
If c.Value <> c.Offset(-1).Value Then
'c.offset(,2) gives you column C
c.Offset(, 2).Value = WorksheetFunction.CountIf(rng, c.Value)
'aplly border
With c.Offset(-1).Resize(, 3).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
End If
Next c
End With
End Sub
Result:
Related
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I need your help in nexted VBA loop. I have some data in two columns and blank rows between rows. This macro loop through a column and find out if it contain certain character. If it' blank then I want it to move to next row. If it contain "Den", then select a specific worksheet ("D-Temp") else select ("M-Temp").
After selecting right Worksheet, it need to fill up text boxs with data from 2nd column as per Row no. The code I have created so far is
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value = "" Then
Next ' `Not getting how to jump to next one`
ElseIf c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
Next
End With
Any help ??
Below is the sample Data I have :
Type Name 1 Name2
DEN Suyi Nick
'Blank row'
PX Mac Cruise
I want macro to Identify Type & select template worksheet (D or M) as per that and fill textboxes on that template with Name 1 & Name2 respectively.
may be you're after this:
Option Explicit
Sub Template()
Dim c As Range
With Sheets("Sample")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced sheet column C not empty cells form row 3 down to last not empty one
Worksheets(IIf(c.Value = "DEN", "D-Temp", "M-Temp")).Copy after:=Sheets(Sheets.Count) ' create copy of proper template: it'll be the currently "active" sheet
With ActiveSheet ' reference currently "active" sheet
.Shapes("Textbox 1").TextFrame.Characters.Text = c.Offset(, 7).Value ' fill referenced sheet "TextBox 1" shape text with current cell (i.e. 'c') offset 7 columns (i.e. column "P") value
.Shapes("Textbox 2").TextFrame.Characters.Text = c.Offset(, 6).Value ' fill referenced sheet "TextBox 2" shape text with current cell (i.e. 'c') offset 6 columns (i.e. column "O") value
End With
Next
End With
End Sub
If I'm not mis-understanding your current nesting...
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End if 'not blank
Next
End With
If I understand your question, correctly, you need to change your if/then logic slightly:
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Exit For
Else
ws = "M-Temp"
Exit For
End If
End If
Next
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End With
End Sub
You might want to add code to make sure that ws is set to something (not all columns were blank).
I am trying to highlight top 2 values for each row for visible cells only using conditional formatting in Excel macro. My range is dynamic, hence I am running a loop to arrive at the last cell of the range.
Here is my code:
With Sheets("pcSupplyChainAnalysis").Select
For i = 2 To ctr
Set rng = Range("C" & i & ":" & "I" & i).SpecialCells(xlCellTypeVisible)
rng.FormatConditions.AddTop10
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 2
.Percent = False
End With
With rng.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
rng.FormatConditions(1).StopIfTrue = False
Next
End With
Ctr is a counter I am running to find the position of the last non blank cell, as my data has blank values too and I am copying it from another sheet using macro.
ctr = 2
Do While (ActiveSheet.Range("A" & ctr).Value <> "")
ctr = ctr + 1
Loop
ctr = ctr - 1
ActiveSheet.Range("B2:I" & ctr).Select
Selection.Cut
Range("C2:J" & ctr).Select
ActiveSheet.Paste
Attached is the image of the format of my data. I want to highlight top 2 numbers for each row and ONLY FOR VISIBLE CELLS (as I am using some filters also in the range).
Try this:
Option Explicit
Public Sub ShowTop2()
Dim rng As Range, visibleRow As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("pcSupplyChainAnalysis")
.Columns.FormatConditions.Delete
Set rng = .UsedRange.SpecialCells(xlCellTypeVisible)
End With
For Each visibleRow In rng.Rows
If visibleRow.Row > 1 Then
With visibleRow.FormatConditions
.AddTop10
.Item(.Count).SetFirstPriority
With .Item(1)
.TopBottom = xlTop10Top
.Rank = 2
.Interior.Color = 255
End With
End With
End If
Next
Application.ScreenUpdating = True
End Sub
An easier way to determine the last used row in column A:
ctr = Worksheets("pcSupplyChainAnalysis").Cells(Rows.Count, "A").End(xlUp).Row
You don't need to Select anything for any of your actions
I've what seems like a pretty simple application with looping and 'If..Then' statements but need some help on structuring it.
In very a basic example, I have a list numbers in column A and the values PM or AM listed in column B. I want to write a loop that will search every value in column B until the end of the data set, and add 12 to each value in column A each time column B has a value of PM. In a nutshell, it would look like this:
If column B = PM
then add 12 to its corresponding cell in column A
else move down to the next row and do the same thing until you reach an empty cell
There are many ways, here is a typical one:
Sub dural()
Dim i As Long
i = 1
Do While Cells(i, "B").Value <> ""
If Cells(i, "B").Value = "PM" Then
Cells(i, "A").Value = Cells(i, "A").Value + 12
End If
i = i + 1
Loop
End Sub
you can set it with For next loop and 2 variables. one for last row and the 2nd for the row count:
Sub Macro1()
Dim LastRow As String
Dim i As Integer
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 2).Value = "PM" Then Cells(i, 1).vlaue = Cells(i, 1).vlaue + 10
Next i
End
'
End Sub
This is another way to do this.
Option Explicit
Sub Add()
Dim rData As Range
Dim r As Range
Set rData = Cells(1, 1).CurrentRegion.Columns("B").Cells
For Each r In rData
If UCase$(r.Value) = "PM" Then
r.Offset(, -1).Value = r.Offset(, -1).Value + 12
End If
Next r
End Sub
I have the below query (thanks to stackoverflow) that will loop through a list of groups and give me the permissions the group will have for a category. In Linqpad I can export the result into one Excel sheet, but I was wondering if it was possible to export each group result in the loop to a separate sheet in the Excel file. I was going to try in C# first, but I was wondering if it can be done via SQL or Linqpad as well.
Also, Ad Hoc Distributed Queries are disabled on the server.
SELECT GroupId, Name
INTO #GroupTemp
FROM [Group]
DECLARE #Id INT
WHILE EXISTS (
SELECT * FROM #GroupTemp
)
BEGIN
SELECT TOP 1 #Id = GroupId
FROM #Temp
SELECT g.NAME AS 'GroupName'
,c.NAME AS 'CategoryName'
,c.CategoryId
,c.ParentCategoryId
,p.[Read]
,p.Edit
,p.[Delete]
,p.[Add]
,p.Share
,p.Admin
FROM GroupCategoryPermission p
INNER JOIN [Group] g ON p.GroupId = #Id
INNER JOIN Category c ON p.CategoryID = c.CategoryID
WHERE g.GroupId = #Id
DELETE #GroupTemp
WHERE GroupId = #Id
END
I just decided to use an Excel macro after I exported the query from Linqpad. My VBA is a little rusty and I have a couple of small issues that I need to work out (I'm sure there is an easier way than I did it), but this is okay for now. Basically, I searched for every row in column one with GroupName as the value. From there I stored those in an array and used the different in between each for each sheet to be added.
Option Explicit
Private Function Sleep()
Application.Wait Now + 1 / (24 * 60 * 60.0# * 2)
End Function
'Remove 1st row of Sheet 1 and blank rows from sheet
Private Function CheckEmpty()
On Error Resume Next
Worksheets(1).Select()
Columns("A").SpecialCells(xlBlanks).EntireRow.Delete()
Rows("1:1").Select()
Selection.Delete Shift:=xlUp
End Function
'Function to get the name of the group and name the sheet that name
Private Function NameSheet()
Dim groupName As String
groupName = ActiveSheet.Range("A2").Value
If Len(groupName) > 31 Then
groupName = Left(groupName, 31)
ActiveSheet.Name = groupName
Else
ActiveSheet.Name = groupName
End If
End Function
'This will format the sheet
Private Function FormatSheet()
Cells.Select()
With Selection
.WrapText = False
End With
Rows("1:1").Select()
Selection.Font.Bold = True
Cells.Select()
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Columns.AutoFit()
End With
End Function
'Main sub to separate groups into their own sheets
Sub SplitToSheets()
'Variables
Dim ws As Worksheet, rng As Range, cell As Range, findString As String
Dim counter As Long, numbers() As Long, lastRow As Long, firstRow As Long
'Clean sheet 1
Worksheets(1).Activate()
CheckEmpty()
FormatSheet()
'Set the range that we will be checking
firstRow = Rows("1:1").Row
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A" & firstRow & ":" & "A" & lastRow)
rng.Select()
'Set the counter so we loop through array
counter = 1
'Loop through array and store row numbers
For Each cell In rng
If cell.Value = "GroupName" Then
ReDim Preserve numbers(counter)
numbers(counter) = cell.Row
'Increase counter by 1
counter = counter + 1
End If
Next
'Separate groups to sheet using numbers array
'Variables
Dim inx As Long, rStart As Long, rEnd As Long, ind As Long
'Copy first group to new sheet on it's own (need to change logic to avoid separation, eventually)
rStart = numbers(1)
rEnd = numbers(2) - 1
Rows(rStart & ":" & rEnd).Select()
Selection.Copy()
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
NameSheet()
FormatSheet()
'Index Counter for looping through array
ind = 0
For inx = LBound(numbers) To UBound(numbers)
'Need to loop once and make sure the counter is greater than 1
If ind > 0 Then
'Revert to sheet 1
Worksheets(1).Select()
'Start row number
rStart = numbers(ind)
'End row number
rEnd = (numbers(ind) - numbers(ind - 1))
'Selection must start on second group
If rEnd > 1 Then
'Select range
Rows(rStart & ":" & rStart + rEnd).Select()
'Copy
Selection.Copy()
'Add next availble sheet
Sheets.Add After:=Sheets(Sheets.Count)
'Paste values
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
'Set sheet name and rename to match group
NameSheet()
FormatSheet()
Sleep()
End If
End If
'Increase index by 1
ind = ind + 1
Next
'This deletes the main sheet that we no longer need
Application.DisplayAlerts = False
Worksheets(1).Delete()
Application.DisplayAlerts = True
Worksheets(1).Activate()
End Sub
'This macro will give option to seach for sheet
Sub GetSheet()
Dim SearchData As String
SearchData = InputBox("Enter 'exact' group name.")
If SearchData <> vbNullString Then
On Error Resume Next
Sheets(SearchData).Activate()
If Err.Number <> 0 Then MsgBox "Unable to find group named: " & SearchData
On Error GoTo 0
End If
End Sub