I know that this row is wrong:
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
I want to rank the whole column D in column E. The numbers should be "grouped" in 39 numbers.
Private Sub CommandButton2_Click()
Dim lrow As Long
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lrow = ws.Cells(Rows.Count, "D").End(xlUp).row 'Find the last row in column D
For i = 2 To lrow Step 39 'Loop every group (group of 13 rows) in column D
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
Next i
End Sub
I think the code will do what you want. Please pay attention to the constants at the top which you have to set to suit your needs.
FirstDataRow - your data seem to start in row 2. So, don't change.
GroupSize - I tested groups of 3 rows. I think you want groups of 39 rows. Change it.
TgtClm - Your data are in column 4 (column D). No need to change now.
Once you have set these 3 constants the code is ready to run. Please try it.
Private Sub CommandButton2_Click()
' 034
Const FirstDataRow As Long = 2
Const GroupSize As Long = 3 ' change to suit
Const TgtClm As Long = 4 ' Target Column (4 = column D)
' the output will be in the adjacent column
Dim Ws As Worksheet
Dim Rng As Range ' cells in one group
Dim lRow As Long ' last used row
Dim Rstart As Long ' first row in group range
Dim Rend As Long ' last row in group range
Set Ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lRow = Ws.Cells(Ws.Rows.Count, TgtClm).End(xlUp).Row 'Find the last used row
Rstart = FirstDataRow
Do
Rend = Application.Min(Rstart + GroupSize - 1, lRow)
With Ws
Set Rng = .Range(.Cells(Rstart, TgtClm), .Cells(Rend, TgtClm))
End With
Rng.Offset(0, 1).Formula = "=RANK(" & Rng.Cells(1).Address(0, 1) & _
"," & Rng.Address & ",0)"
Rstart = Rend + 1
If Rstart > lRow Then Exit Do
Loop
End Sub
Note that the final 0 in the RANK formula (here: & Rng.Address & ",0)") instructs to rank in desscending order, meaning the highest number will get the lowest rank (100 = 1, 90 = 2 etc). Change to 1 if you need the opposite order.
I do not know this topic so well, but on the webpage
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.rank_eq
Is written that expression.Rank_Eq (Arg1, Arg2, Arg3), and the
expression A variable that represents a WorksheetFunction object.
In your code it looks like a Range object.
Related
I need to create a column with the difference between a column and a cell (A3) in a loop.
In the picture I would for example like to know impact 1 with the H3 to a H.. = scenario(F3 to F...) - A3 and impact 2= Scenario2(G3...G)-A3 for x years (B3) for example.
I started with an if loop but I struggled to loop the whole column.
Sub Lab1()
Dim i As Integer
If i <= Range("B3").Value Then
Range("H3").Value = Range("F3").Value - Range("A3").Value
Range("J3").Value = Range("G3").Value - Range("A3").Value
End If
i = 2020 + Range("B5").Value
End Sub
I'm a little iffy on where column P from your code comes into play with your screenshot, but this should roughly do what you're looking for I think. Let us know if you run into any issues!
Sub loop1()
'define variables to work with
Dim ws As Worksheet
Dim interCol As Long, scen1Col As Long, impact1Col As Long
Dim firstRow As Long, lastRow As Long
Dim rng As Range
Dim intervention As Long, scenario As Long
Dim i As Long
'define current worksheet
Set ws = ActiveSheet
'define column numbers
interCol = 1 'A
scen1Col = 6 'F
impact1Col = 8 'H
'define start row
firstRow = 3
'end row is the last non-blank cell in Scenario 1 column
lastRow = ws.Cells(ws.Rows.Count, scen1Col).End(xlUp).Row
'loop from first row to last row
For i = firstRow To lastRow
'define cell to update
Set rng = ws.Cells(i, impact1Col)
'intervention doesn't change from row to row
intervention = ws.Cells(firstRow, interCol)
'scenario varies from row to row
scenario = ws.Cells(i, scen1Col)
'update target cell with calculation
rng = scenario - intervention
Next i
End Sub
My knowledge in VBA coding is zero. I wonder if someone can help with this question, please.
I have this initial code tried to write but it is wrong. I was not sure how to add these below conditions in the code.
Question: I want to auto number column A which starts at a specific Cell, A3 and it auto-numbers as long as there is text in Column B and Column C.
Here's the sample data picture. Thanks in advance!
Sub test()
Set r = Range("a3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
With r
If .MergeCells <> True Then
r = r +1
Else
' Skip
End With
End Sub
Assuming your sheet is named Sheet1, you may use something like this:
Sub Test()
Dim lastRow As Long, i As Long, counter As Long
With Sheet1
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Not IsEmpty(.Cells(i, 2)) And Not IsEmpty(.Cells(i, 3)) Then
counter = counter + 1
.Cells(i, 1).Value = counter
End If
Next
End With
End Sub
Note: Using IsEmpty to check if any of the cells in columns B & C is empty already covers the case of cells being merged because in that case, at least one of the two cells has to be empty anyway.
Demo:
You have r as a range, you can't add a number to it and have it increment the range. (Though I did just test it and it doesn't throw an error which is strange)
Also Skip is not a thing in VBA, if you want to skip in a loop you need a conditional or a goto. Though you have no loop.
Sub test()
Dim i As Long
Dim lastrow As Long
Dim counter As Long
counter = 1
With ActiveSheet ' Change this to the real sheet name
lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row ' Gets Last row
For i = 3 To lastrow ' Loop
If not isempty(.Cells(i, 2).Value) And not IsEmpty(.Cells(i, 3).Value) Then ' Looks for Text
If Not .Cells(i, 1).MergeCells Then ' Looks for merged cells
.Cells(i, 1).Value = counter ' Adds count
counter = counter + 1 ' Increments count
End If
End If
Next i
End With
See for comments and customize to fit your needs:
Public Sub AutoNumber()
' Declare objects
Dim evalRange As Range
Dim evalCell As Range
' Declare other variables
Dim sheetName As String
Dim initialCellAddress As String
Dim lastRow As Long
Dim columnNumber As Long
Dim counter As Long
' Customize to fit your needs
sheetName = "Sheet1"
initialCellAddress = "B2"
counter = 1
' Get column number and last row number to define the range address ahead
columnNumber = Range(initialCellAddress).Column
lastRow = ThisWorkbook.Worksheets(sheetName).Cells(Rows.Count, columnNumber).End(xlUp).Row
' Define the range to be evaluated
Set evalRange = ThisWorkbook.Worksheets(sheetName).Range(initialCellAddress & ":" & Left$(initialCellAddress, 1) & lastRow)
' Loop through each cell in range (in the original example we'll loop through column b)
For Each evalCell In evalRange
If evalCell.MergeCells <> True Then
' Assign the counter to the column at the left (offset = -1) of the evaluated cell
evalCell.Offset(rowoffset:=0, columnOffset:=-1).Value2 = counter
counter = counter + 1
End If
Next evalCell
End Sub
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub
I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next
I have an excel sheet with headers in row 1 and values for each of those columns from -2 to 2 in the subsequent rows. I would like to delete a column (including the header) if each row contains the value 0.
Example: I have three columns A, B, and C and 1500 rows. The header for each of these rows are Patient 1, Patient 2, and Patient 3. Patient 3 contains 0 in each of the 1499 rows and I want to have a final spreadsheet with just Patient 1 and Patient 2.
Thanks for your time.
You could try something like this:
Sub RemoveZeroBasedColumns()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")
Dim iLastCol As Integer
Dim iLastRow As Long
Dim iC As Integer
With oWS
iLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
For iC = 1 To iLastCol
If WorksheetFunction.CountIf(Range(Chr(64 + iC) & ":" & Chr(64 + iC)), 0) = iLastRow Then
.Columns(iC).Delete shift:=xlShiftToLeft
iLastCol = iLastCol - 1
End If
Next
End With
End Sub