Dynamic Logic in Excel Vba - excel

I have a excel workbook which has 30 worksheets in it. Each sheet looks something like this
Now i want to insert a column after "I" column (the new column will be J)and the values should be some thing like this
for coupon 2.000(4-7 rows) the values in the new column J should be = i4-i5(For all J4,5,6,7)
This should be repeated for each coupon.
I tried recording the macro but did not help.
Please provide me sample logic to handle this dynamically.
Thank you in advance.

From your description, it sounded like this is what you are looking for. Please let me know if that is not the case.
Sub AddNewColumn()
Dim sColumnToIns, sCouponField, sCouponGroup, _
sFormula, sCell1, sCell2, sMarketValueField, sColumnToInsHeader, sTopCellOfData
Dim rData As Range
Dim rRng As Range
Dim rCell As Range
Dim oSh As Worksheet
'Make sure you change the sheet to reflect
'the object name of your sheet.
Set oSh = Sheet2
sColumnToIns = "J"
sColumnToInsHeader = "New Column"
sCouponField = "B"
sMarketValueField = "I"
sTopCellOfData = "A4"
'Insert a new column
Sheet1.Range(sColumnToIns & ":" & sColumnToIns).Insert xlShiftToRight
'Get lowest cell in used range
Set rRng = oSh.UsedRange.Cells(oSh.UsedRange.Rows.Count, oSh.UsedRange.Columns.Count)
Set rData = oSh.Range(sTopCellOfData, rRng)
'Set the header text
rData.Range(sColumnToIns & "1").Offset(-1).Value = sColumnToInsHeader
'Go through the entire data set. Whenever the value in the 'Coupon'
'column changes, put a formula the subtracts the top market value
'from the next market value down.
sCouponGroup = ""
For Each rCell In rData.Columns(sCouponField).Cells
If sCouponGroup <> rCell.Value Then
sCouponGroup = rCell.Value
sCell1 = rCell.EntireRow.Columns(sMarketValueField).Address
sCell2 = rCell.EntireRow.Columns(sMarketValueField).Offset(1).Address
sFormula = "=" & sCell1 & "-" & sCell2
End If
rCell.EntireRow.Columns(sColumnToIns).Formula = sFormula
Next
End Sub

Related

VBA macro concatenate 2 columns in new column

I want to create a macro that inserts new column with column name (BL & Container) and then concatinates 2 column in newly inserted column.
In this column I named BL & Container is a new column added my macro.
Further I want the macro to concatenate the values present in column H and F macro should find column H and F by column name and concatenate the them in to newly inserted column I.
My codes below
Sub insert_conc()
Dim ColHe As Range
Dim FindCol As Range
Dim con As String
Dim x As Long
Set FindCol = Range("1:1") 'Looks in entire first row.
Set ColHe = FindCol.Find(what:="BL/AWB/PRO", After:=Cells(1, 1))
With ActiveWorkbook.Worksheets("WE")
ColHe.Offset(0, 1).EntireColumn.Insert
ColHe.Offset(0, 1).Value = "WER"
'x = Range("A" & Rows.Count).End(xlUp).Row
con = "=H2&""-""&F2"
ColHe.Resize(x - 1).Formula = con
End With
Application.ScreenUpdating = True
End Sub
[![Error in code][3]][3]
In this code line " con = "=H2&""-""&F2"" please advise how do I update column nameinstead of H2 and F2 macro should find columna H2 and F2 header name and then concatinate the values in newly inserted column I BL & container. Please advise.
Please, use the next adapted code:
Sub insert_conc()
Dim sh As Worksheet, x As Long, ColHe As Range
Dim FindCol As Range, con As String, firstCell As Range
Set sh = Worksheets("LCL")
x = sh.Range("A" & sh.rows.count).End(xlUp).row
Set FindCol = sh.Range("1:1") 'Looks in entire first row.
Set ColHe = FindCol.Find(what:="BL/AWB/PRO", After:=sh.cells(1, 1))
ColHe.Offset(0, 1).EntireColumn.Insert
ColHe.Offset(0, 1).value = "BL & Container"
Set firstCell = ColHe.Offset(1, -2) ' determine the cell to replace F2
con = "=" & ColHe.Offset(1).Address(0, 0) & "&" & firstCell.Address(0, 0)
ColHe.Offset(1, 1).Resize(x - 1).Formula = con
End Sub
It is also good to know that using With ActiveWorkbook.Worksheets("LCL") makes sense only if you use it in the code lines up to End with. And your code did not do that... It should be used before, in order to deal with the appropriate sheet, even if it was not the active one.

Assigning a row range to a variable

I have been trying so hard. I cant figure this out. I am working with two sheets. One sheet searches for a criteria "RR", ir there is an RR, it assigns a variable a serial to be searched in another sheet. If the serial is found in the other sheet, I would like to determine the row where it is located and assign it to a variable. "DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value" The problem when I use thiscell.Row, its giving me so many problems. I need the row number to so I can reference the same row to get information from another cell on the same row. Please help.
Sub TempModifier()
Dim NYSID, PLookUpTabRange, IsRR, DidTransfer As String
Dim thiscell As Range
'Variable for Temp
Dim TempFirstRow As Integer
Dim TempLastRow As Long
'Variables for the previous
Dim PreviousTabLastRow As Long
Dim PreviousTabFirstRow As Integer
'Initialize the temp variables
TempLastRow = Sheets("Temp").Range("D" & Rows.Count).End(xlUp).Row
PreviousTabName = "February"
PreviousTabFirstRow = 7
With Sheets(PreviousTabName)
PreviousTabLastRow = .Cells(256, "H").End(xlUp).Row 'Get the last row in the data range
End With
'Create a data-range variable
PLookUpTabRange = "H" & PreviousTabFirstRow & ":" & "H" & PreviousTabLastRow
'Begin looping structure to copy data from the temp tab to the current tab
For TempFirstRow = 2 To TempLastRow
'Assign the value of the housing unit
IsRR = Sheets("Temp").Cells(TempFirstRow, 2).Value
'Check if the value is RR
If IsRR = "RR " Then
'If the value is RR, then get the NYSID
NYSID = Worksheets("Temp").Cells(TempFirstRow, 4).Value
If Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Then
'NYSID is Found on Current Month Sheet, do Nothing
Else
DidTransfer = ""
Set thiscell = Sheets(PreviousTabName).Columns("D").Find(What:=NYSID, LookIn:=xlValues, lookat:=xlWhole)
DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value
Select Case DidTransfer
Case "Transferred"
DidTransfer = "Transferred"
Case Else
DidTransfer = DidTransfer
End Select
If IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Or _
(Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) And _
DidTransfer = "Transferred") Then
'Worksheets("Temp").Rows(TempFirstRow).Delete
MsgBox "Delete"
End If
End If
End If
'Go to the next row
Next TempFirstRow
End Sub

How do I use a Match function and reference the row number it returns?

I'll do my best to explain this. I'm working in a spreadsheet that contains roughly 150 columns and 2,500 rows. In column D, there is an identification number that is unique to that line. I need to filter on that column for a specific ID number (say B5555) then subtract the value in column AH of that row from the values in columns AB, O and M of that row. Then I need to zero out the value in column AH.
Filtering for the ID number is no problem but B5555 could show up in any row. IE, one week it shows up in row 2,300 and the next it is in 1,500, so I can't just make the formula say subtract AH2300 from AB 2300 because the next week that will act on the wrong cells. How do I make the formulas subtract specifically from the line that B5555 shows up in? The code I have so far only filters for that ID number so it isn't much but is shown below. I'm new to VBA os nay help would be much appreciated.
Sub ManualAdjustments()
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Dim rownum As Integer
Set wbTarget = Workbooks("Weekly Data")
wbTarget.Activate
Worksheets("Raw").Activate
rownum = Application.WorksheetFunction.Match("B5555",
Sheets("Raw").Range("D:D"), 0)
The above code is what I have so far. How do I reference "rownum" in a simple subtraction formula? Would it be: Worksheets("Raw").Range("AHrownum")-Worksheets("Raw").Range("ABrownum")
You could do this as below:
Sub ManualAdjustments()
Dim rownum As Long
Dim ws As Worksheet: Set ws = Worksheets("Raw")
'Get the row number where value "B5555" is found in Column D
rownum = ws.Range("D:D").Find(What:="B5555", Lookat:=xlWhole).Row
'Subtract AH minus AB, O & M
NewValue = ws.Range("AH" & rownum) - ws.Range("AB" & rownum) - ws.Range("O" & rownum) - ws.Range("M" & rownum)
MsgBox "Your New Value is: " & NewValue
End Sub
Slightly different approach:
Sub ManualAdjustments()
Dim wbTarget As Workbook
Dim shtTarget As Worksheet
Dim wbThis As Workbook
Dim strName As String
Dim rownum As Long '<<< safer never to use Integer...
Set wbTarget = Workbooks("Weekly Data")
Set shtTarget = wbTarget.Sheets("Raw")
'no "worksheetfunction" = no runtime error if no match
rownum = Application.Match("B5555", shtTarget.Range("D:D"), 0)
If Not IsError(rowNum) Then '<< test for successful match here
With shtTarget.Rows(rownum)
'Here Range() is *relative to the row*
.Range("C1").Value = .Range("A1").value = .Range("B1").Value
End With
End if
End Sub

Rearrange data in a column

Is there any way to automatically arrange this data
Into this
Using excel/google sheets/etc. Basically I have a huge list of files (second column) that I need to map to it's respective folder (first column ID).
What I need, is to copy column A data down, but only to the blank cells immediately below, and then do it again for the new folder id, and so on.
I happen to have a macro that prompts the user which column to copy data down. See the below (Note you may need to tweak as necessary):
Sub GEN_USE_Copy_Data_Down()
Dim screenRefresh$, runAgain$
Dim lastRow&, newLastRow&
Dim c As Range
Dim LastRowCounter$
Dim columnArray() As String
screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo)
If screenRefresh = vbYes Then
Application.ScreenUpdating = False
Else
Application.ScreenUpdating = True
End If
Dim EffectiveDateCol As Integer
LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row")
CopyAgain:
With ActiveSheet
lastRow = .UsedRange.Rows.Count
End With
' THIS WILL ASK THE USER TO SELECT THE COLUMN TO COPY DATA DOWN
MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range" & vbCrLf & "below the current cell, to the next full cell")
Dim Column2Copy As String
Column2Copy = InputBox("What columns (A,B,C, etc.) would you like to copy the data of? Use SPACES, to separate columns")
columnArray() = Split(Column2Copy)
Dim startCell As Range
For i = LBound(columnArray) To UBound(columnArray)
Debug.Print i
Column2Copy = columnArray(i)
Set startCell = Cells(1, Column2Copy).End(xlDown)
Do While startCell.row < lastRow
If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then
newLastRow = lastRow
Else
newLastRow = startCell.End(xlDown).Offset(-1, 0).row
End If
Set CopyFrom = startCell
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = CopyFrom.Value
Set startCell = startCell.End(xlDown)
Loop
Next i
If screenRefresh = vbYes Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = True
End If
End Sub
I wrote it a while ago, so it might be able to have lines removed/combined, but it should work (assuming you're trying to just copy data down column A).
In Excel, select the left-hand column, HOME > Editing, Find & Select, Go to Special..., check Blanks (only), OK, then select one of the chosen cells, =, Up, Ctl+Enter.

VBA to add totals and formula to multiple sheets

I have an excel sheet with around 200 work sheets each containing a list of products sold to a company.
I need to add
A total at the bottom of row D-G where the bottom can be a different value. I.E. E4
below the total a formula based on the total. I.E. if E4 (being the bottom of the above row) is below $999 the display text "samples", if between 1000-3000 then multiply E4 by 2%, 3001-7500 x 5% etc.
I need to be able to add it to the entire workbook easily using vba. Since I must do this to numerous ss it would literally save me 15-20 hours a month.
Edit:
So I have something that seems to be the right path.
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A3", .Range("A65536").End(x2Up))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Dim colm As Long, StartRow As Long
Dim EndCell As Range
Dim ws As Worksheet
StartRow = 3
For Each ws In Worksheets
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
If EndCell.Row > StartRow Then EndCell.Resize(, 4).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
Set EndCell = ws.Cells(Rows.Count, "D").End(xlUp)
If EndCell.Row >= 1000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.05))
Range(J3) = "5% Discount"
ElseIf EndCell.Row >= 3000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.1))
Range(J3) = "10% Discount"
End If
Next ws
End Sub'
Just need to figure out how to display the results and text to the right cells (J2 in this case)
I will supply the logic and all the references you need to put this one together; and will let you try to put it together on your own :). Come back for more help if needed.
You need to loop through all the worksheets in your workbook (Microsoft Tutorial)
You need to find the last row for the given columns (Online tutorial)
You need to use an IF statement to choose which formula to use (MSDN reference)
UPDATE
What's wrong with your code is this line :
Range(J2) = Formula = ((EndCell.Row) * (0.1))
What you're telling the computer is :
Multiply EndCell.Row by 0.1 (which has the number of the row below and to the right of the last cell in column C)
Compare Formula with the result previously obtained
Store the result of that logical expression at the range stored in variable J2
First of all, what you want is to put the result of the equation, and want to change J2 to "J2" so it gets the cell J2, instead of the what's contained in J2 (which has nothing at that point)
Also, you seem to say that you're not getting the right cells, maybe it is caused by this :
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
In that line, you're finding the last cell of column C, but then you select the cell below, and to the right of it.
There are so many things wrong with your code it's hard to say what's not working properly.

Resources