Use code to modify Excel formulas - vba

I have an Excel 2010 workbook with 22 worksheets in it. The first worksheet is labeled DATA, where data is entered by a user. Row A1-N1 contain labels. Rows A2-A18 contains data for January 2015 for the 17 locations beginning as cell A2, i.e. row 2 contains data for location 1, row 3 for location 3, etc. February data begins at row 19, March begins at row 36, etc.
On each worksheet A1-M1 are labels and rows 2-13 are the months January - December. Cell B2 on worksheet #2 references cell J2 on the worksheet DATA. The other formulas on row 2 of worksheet #2 reference cells on row 2 on worksheet DATA. Row 3 of worksheet #2 references cells on row 19 of DATA. In column N of each location worksheet has a number in cell N2 that corresponds to the appliable row on the worksheet DATA.
Here is an example of one of my formulas:
=(IF(ISBLANK(DATA!D2),"-",IF(ISERROR(DATA!E2/DATA!D2),"N/A",(DATA!E2/DATA!D2)))).
I would like to have VB code, or a macro?, that would edit every formula on each worksheet by replacing the current number in the formula with the number in column N of that same row, i.e. if N7 contained the number 88 the code would alter any formula on that row by removing the current number in the formula and replacing with the number 88.
Additional information:
On each worksheet there are different formulas for columns B-M. The code would need to take the number in column N for that row and replace whatever number is in that formula with the number in column N of that row, for each row, for each worksheet.
Currently, I have to touch each formula on every worksheet and this is too time consuming. Beginning in April the locations will increase from 17 to 148 which will require coding to make the appropriate changes.
DATA worksheet image
1R location worksheet image

I am not on my work computer, so I haven't had the opportunity to test out this code, but I believe this should do what you want. If there are any issues with it, let me know, and I'll have a look at it at work tomorrow.
Sub replace_numbers()
Dim ws As Worksheet
Dim c As Range
Dim replace_with As Long
Dim objRegex As Object
'Application.EnableEvents = False
'Application.ScreenUpdating = False
'Application.DisplayStatusBar = False
'Application.Calculation = xlCalculationManual
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "\d+"
End With
For Each ws In Worksheets
If ws.Name <> "DATA" Then
For Each c In ws.Range("B2:M13")
replace_with = CLng(Intersect(ws.Columns("N"), ws.Rows(c.Row)).Value)
c.Formula = objRegex.Replace(c.Formula, replace_with)
Next
End If
Next
'Application.EnableEvents = True
'Application.ScreenUpdating = True
'Application.DisplayStatusBar = True
'Application.Calculation = xlCalculationAutomatic
End Sub
If the code runs as intended, remove the apostrophes before the Application-calls, in order to make the code run somewhat faster.

You can always use something like:
If IsEmpty(Worksheets("DATA").Cells(2, 4)) And _
IsError(Worksheets("DATA").Cells(2, 5).Value / Worksheets("DATA").Cells(2, 4).Value) Then
ActiveCell = "NA"
Else
ActiveCell = Worksheets("DATA").Cells(2, 5).Value / Worksheets("DATA").Cells(2, 4).Value
End If
Which is the formula you have translated to VBA code.
However, you must add error handlers, and other stuff according to what you have in your input data.

Related

Excel VBA find row number based on criteria in two columns, no loop

A little background, my sheet "Data" consists of a table, which my macro is supposed to populate. The table has dates running down the first column (Column P), and a few names as headers. My current macro, as seen below, loops through all my sheets, except the ones specified not to loop through, then in each sheet it loops through each cell in the range W7:W200. It then looks to match the right 10 values in the cell with a date in the column P on sheet "Data" (and sets that row as HdrRow). At the same time, it looks for the value in A9 in whatever sheet it is looping through, in order to match that value to a column header in sheet "Data" (and sets that column as HdrCol). After finding the row and column (intersecting cell), the macro then pastes the values of the cell it is looping through into that intersecting cell.
I am having trouble with this next part, I am looking to add another criteria for finding a row. I would like the macro to not only find a matching date in column P, but also a value in column Q that matches with the value in A1 of whichever sheet it is looping through; and then set that row as HdrRow. If possible, id like to not use a loop for this.
Sub Values()
Dim HdrCol As Range
Dim Site As String
Dim SearchRange As Range
Dim HdrRow As Range
Dim FinDate As Date
Dim ws As Worksheet
Dim rng As Range
' Fill in Actual Value
Sheets("Data").Range("W2:W100000").ClearContents
For Each ws In ActiveWorkbook.Worksheets
'Dont Copy Data from these worksheets
If ws.Name <> "Portfolio" And ws.Name <> "Master" And ws.Name <> "Template" _
And ws.Name <> "Coal" And ws.Name <> "E&P" And ws.Name <> "Gen" _
And ws.Name <> "Hydro" And ws.Name <> "LNG" And ws.Name <> "Midstream" _
And ws.Name <> "Solar" And ws.Name <> "Transmission" _
And ws.Name <> "Wind" And ws.Name <> "Data" Then
For Each cell In ws.Range("W7:W200")
If cell <> " " Then
Site = ws.Range("A9").Value
FinDate = Right(cell, 10)
'Find column ref
Set HdrCol = Sheets("Data").Range("P1:W1").find(Site, lookat:=xlPart)
If Not HdrCol Is Nothing Then
End If
'Find row ref
Set SearchRange = Sheets("Data").Range("P1", Range("P100000").End(xlUp))
Set HdrRow = SearchRange.find(FinDate, LookIn:=xlValues, lookat:=xlWhole)
Application.Goto Reference:=Cells(HdrRow.Row, HdrCol.Column)
If IsEmpty(Sheets("Data").Cells(HdrRow.Row, HdrCol.Column)) Then
cell.Copy Sheets("Data").Cells(HdrRow.Row, HdrCol.Column)
Else
cell.Copy Sheets("Data").Cells(HdrRow.Row, HdrCol.Column).End(xlDown).Offset(1, 0)
End If
End If
Next
End If
Next
End Sub
My first thought for a non-loop version to do this (loop is much simpler), would be to use match(), though if you have multiple values where A=Q or the same date is used, you might run into an issue.
Dim i,j as Integer
i=Application.Match(RefCell1,LookUp1,0).Row
j=Application.Match(RefCell2,LookUp2,0).Row
If i=j Then
HdrRow=i
Else
End If
I am specifically not making that match scenario the If statement condition so it's easier to read and edit.
You would run into issues where you have multiple of the same values, using this approach.
Another approach is to use a nested if statement:
Dim i as integer
i=Application.Match(RefCell1,LookUp1,0).Row
If Application.IfError(i,0)>0 Then
If Cells(i,"Q").Value=Cells(RefCell1Row,"A").Value
HdrRow=i
Else
End If
Else
End If
In the end, I would still recommend a loop so you can assess line per line, which would build on the second approach.
Edit: Per request, to include a loop.
Dim i, j as Integer
For i = 7 to 200 'Used the range you mentioned in your post, which I think is wrong for this example... these are row numbers for Data sheet
For j = 7 to 200 'Row numbers for reference sheets
If Sheet(ARRAY).Cells(j,"Q").Value=Sheets("Data").Cells(i,"A").Value Then
If Cells(j,"P").Value=Cells(i,"B").Value 'Not sure what column the date is in Data sheet
HdrRow=j
Else
End If
Else
End If
Next j
Next i
Ends up being two loops, to account for the cells on both your data sheet, and each sheet you're referencing in the array. Make sure to turn off screen updating, because epilepsy is real!

VBA Excel Adjusting Row Height

I am creating a report in Excel and I would like VBA to format the row height based upon the value in column K. For example, if cell K17 = 11.25, I want row 17 to be 11.25. Cell k18 = 21.75 so row 18 =21.75.
I need vba to change every row from 17-400.
This should be relatively simple but I can't seem to come up with the correct coding.
Since this is an easy one, I went ahead and provided the answer for you:
Sub RowHeight()
Dim ws as Worksheet
Set ws = Sheets("mySheet") 'replace with your sheet name
Dim rCell as Range
For each rCell in ws.Range("K17:K400")
rCell.EntireRow.RowHeight = rCell.Value
Next
End Sub

how to copy & paste the data from one column to another between two sheets of excel workbook...without overwriting the destination column content..?

how to copy & paste the data from one column to another between two sheets of excel workbook ... without overwriting the destination column content?
I am using below code to copy & paste but every time I run it it is overwriting the existed content. I want to be pasted from next row of the column.
Sub DirectCopySample()
Application.ScreenUpdating = False
Sheets("Updating Sheet").Range("A:A").Copy Destination:=Sheets("Sheet1").Range("G:G")
Sheets("Updating Sheet").Range("B:B").Copy Destination:=Sheets("Sheet1").Range("F:F")
Sheets("Updating Sheet").Range("C:C").Copy Destination:=Sheets("Sheet1").Range("B:B")
Application.ScreenUpdating = True
End Sub
Don't copy the entire column. Copy a specific 1-cell-wide range of X rows (where X is your data) and define all your variables based on the current size of the data. For instance if you want to copy column A from sheet1 to the end of column B in sheet2.
Sub CopyColumn()
Dim wsCopy As Worksheet
Set wsCopy = Sheets("<Sheet Name>")
Dim wsPaste As Worksheet
Set wsPaste = sheets("<Sheet Name>")
'/ Much better to make your worksheets variables and then reference those
Dim lngFirstRow As Long
Dim lngFinalRow As Long
Dim lngCopyColumn As Long
Dim lngPasteColumn As Long
Dim rngCopy As Range
Dim rngPasteCell As Range
lngCopyColumn = 1 '/ ("A" Column)
lngDestinationColumn = 2 '/ ("B" Column)
wsCopy.Activate
lngFirstRow = 1
lngFinalRow = Cells(1048576, lngCopyColumn).End(xlUp).Row
'/ Starts at the bottom of the sheet, stops at the first cell with data in it, returns that cell's row
Set rngCopy = Range(Cells(lngFirstRow, lngCopyColumn), Cells(lngFinalRow, lngCopyColumn))
'/ Defines the range between those 2 cells
rngCopy.copy
wsPaste.Activate
lngFinalRow = Cells(1048576, lngPasteColumn).End(xlUp).Row
Set rngpaste = Cells(lngFinalRow + 1, lngPasteColumn)
'/ Pastes to the row 1 cell below the last filed cell in Column B
rngpaste.Paste
End Sub
#Grade 'Eh' Bacon outlined the correct process in his or her comment.
The crux of the issue is finding the size of the ranges you are copying from and pasting to. My current favorite method of doing so is the code snippet below:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
That will find the last non-empty row in your worksheet. So if for some reason column A has 100 rows, B has 200 rows, and C has 300 rows it will return 300 as the last row.
On the paste side of things, you could use the same method and add 1 to it so you paste into the first empty row, but if the columns have different numbers of rows you will end up with many blank rows in the shorter columns before your data is pasted at the bottom.
A work around this is the following code:
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
This will start at the bottom of column G and head up until it hits a row with data in it and then add 1 so that you are pasting into the first blank row of the column. You could then create variables for columns H and I that do the same thing.
Putting it all together your code would look something like this in the end:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
'pasteLastrowH ...
'pasteLastrowI ...
Sheets("Updating Sheet").Range("A2:A" & copyLastrow).Copy Destination:=Sheets("Sheet1").Range("G" & pasteLastrowG)
'Copy and paste B code here
'Copy and paste C code here

Need to summarize data from multiple excel worksheets onto one summary page

I'm trying to create a yearly summary for some of our transfers. Essentially, I have 12 sheets, one for each month of the year, and each entry is given one of four specific "Transfer Rationales" in column L. I need to be able to create a worksheet that gives me a running year-to-date summary based on each transfer rationale.
So say, for example, the transfer rationale I'm looking at is called "Incorrectly Assigned" - I think need to have the summary page show columns G-K of each row where column L is "Incorrectly Assigned" from all twelve month sheets.
I've been looking at VBA code and trying to tweak some to work, but I could use some help!
EDIT:
Obviously it's not working as I need or I wouldn't be here, but I don't have much knowledge about VBA. I have something here where the code is grabbing the entries where column L met the criteria, but it was
a) copying all the columns, and I only need G-K to paste, and
b) was putting the copied rows all in one row in the summary tab, so I could see the data for a split second, and then it would overwrite with the next line and so on until it finally settled on the last entry found.
SECOND EDIT:
So I have a code that now (mostly) works, I've pasted it below and deleted the old code above.
Private Sub CommandButton1_Click()
Dim WkSht As Worksheet
Dim r As Integer
Dim i As Integer
i = 1
For Each WkSht In ThisWorkbook.Worksheets
i = i + 1
If WkSht.Name <> "Incorrectly Assigned" Then
For r = 1 To 1000
If WkSht.Range("L" & r).Value = Sheets("Incorrectly Assigned").Range("A1").Value Then
WkSht.Range("E:L").Rows(r & ":" & r).Copy
Sheets("Incorrectly Assigned").Range("E:L").End(xlUp).Offset(i, 0).PasteSpecial Paste:=xlPasteValues
End If
Next r
End If
Next WkSht
End Sub
The problem now is that it is only grabbing the last match from each worksheet - so say January has four matching entries, it's only pasting the fourth entry, then the next row down it'll paste the last entry from February etc. and then if there's an entry in say November that matches, it'll be pasted in the 11th row from the beginning, rather than each entry being pasted one after another.
Better to create a sub-routine that you call from your "CommandButton1". Then you can call the procedure from more than one location. You can also generalize it by using an input parameter 'transferID' which defines the summary you want.
Private Sub CommandButton1_Click()
Call PrintSummary("Incorrectly Assigned")
End Sub
It will likely need some tweaking to get it how you want, but this should give you some ideas to get you started:
Sub PrintSummary(transferID As String)
Dim ws As Excel.Worksheet
Dim wso As Excel.Worksheet
Dim lrow As Long
Dim rng As Excel.Range
Dim rngo As Excel.Range
Dim cell As Excel.Range
Dim colH As Variant
Dim i As Integer
'// Define columns for output
colH = Array("G", "H", "I", "J", "K")
'// Check for summary sheet (for output)
On Error Resume Next
Set wso = ThisWorkbook.Worksheets("Summary")
On Error GoTo 0
If wso Is Nothing Then
'// Summary worksheet does not exist :/
Exit Sub
Else '// format worksheet for output
'// for example...
wso.Cells.Delete Shift:=xlUp
Set rngo = wso.Range("A1") '// define output start
Set wso = Nothing
End If
'// Loop through worksheets
For Each ws In ThisWorkbook.Worksheets
'// Check for valid worksheet name
Select Case VBA.UCase(ws.Name)
Case "JAN", "FEB" '// and so forth...
Set rng = ws.Range("L1")
Set rng = ws.Range(rng, ws.Cells(Rows.Count, rng.Column).End(xlUp))
For Each cell In rng
If (VBA.UCase(cell.Text) = VBA.UCase(transferID)) Then
'// Print meta data
rngo.Offset(lrow, 0).Value = ws.Name
rngo.Offset(lrow, 1).Value = transferID
'// Print values
For i = 0 To UBound(colH)
rngo.Offset(lrow, i + 2).Value = ws.Cells(cell.Row, VBA.CStr(colH(i))).Value
Next i
'// Update counter
lrow = lrow + 1
End If
Next cell
Case Else
'// Not a month? do nothing
End Select
Next ws
End Sub
You do not need VBA - just refence the cell in the other tab:
SheetName!CellAddress
Precede the cell address with the worksheet name, and follow it with an exclamation point.
If you need VBA, then I have understood your question incorrectly.
EDIT:
Lets start with problem B:
was putting the copied rows all in one row in the summary tab
Lets look at the code you use to paste values:
Sheets("Summary").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Here you always paste everyting in the same place, in cell A65536 which you offset by one. On every iteration of your loop, the values will be at the same place. Change the Offset(1) to
Offset(0, r)
Now on every iteration you will paste on a different row, because r will be 1, 2, ..., 1000. See MSDN for documentation on Offset. Select a values that accomplished a paste the way you need.
Lets go to the next question:
a) it was copying all the columns
I will edit once the first part works as it should for you.

Find If cell matches in another sheet and count/sum instances

I have been using simple excel array formulas to count certain values on a master sheet but now at the point where I have too many formulas in my document and excel is crashing.
Therefore, I would like to create a macro that can do the same task. I would like to have the code do the following:
IF the activecell in Sheet1 matches to any cell in a column(or range) in Sheet2,
AND IF the cell in the same row in an adjacent column in Sheet2 is not blank,
THEN count all the instances that specific string appears in Sheet2 column A
AND place the value 2 columns to the right of the original active cell in Sheet1.
Here is the original array formula I was using:
=SUM(IF(Sheet1!$A8=Sheet2!$A:$A,IF(SalesF_SignUp_data!$C:$C>1,1,0)))
The formula above is taking the cell A8 in Sheet1 and checking if it matches to any cell in Sheet2 column A,
AND making sure that column C in Sheet2 is not blank in the same row.
If this is TRUE then "add 1" for all the instances
AND place that value in Sheet1.
I believe the best way to do this is a For Next Loop but haven't been able to execute any successful code based on examples I've found.
Im happy to explain further if needed. Since I dont have a reputation of 10 I cant attach images but am willing to send if needed.
This is set up to run for all the cells you've selected in column A of sheet 1.
It looks in Sheet2 column A for the value on Sheet1 column A, then in Sheet1 column B, displays how many times the value appeared in Sheet2 column A along with a value in the same row of column C.
If the answer is helpful, please mark it as such. :-)
Option Explicit
Sub countinstances()
Dim result, counter, loopcount, tocomplete, completed As Integer
Dim findtext As Variant
Dim cell, foundcell, nextcell As Range
'Checks to make sure the sub isn't accidentally run on an invalid range
If ActiveSheet.Name <> "Sheet1" Or ActiveCell.Column <> 1 Or Selection.Columns.Count > 1 Then
MsgBox ("Please select a range in column A of Sheet 1.")
Exit Sub
End If
'In case of selecting the entire column A, curtail the number of blank cells it runs on.
tocomplete = Application.WorksheetFunction.CountA(Selection)
completed = 0
'For each cell in the selected range, searches Sheet2, Column A for the value in the selected cell
For Each cell In Selection
If completed = tocomplete Then Exit Sub
If cell.Value <> "" Then completed = completed + 1
findtext = cell.Value
result = 0
Set foundcell = Sheets("Sheet2").Range("A1")
'Uses the count function to determine how many instances of the target value to search for and check
loopcount = Application.WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), findtext)
'Skips the loop if the target value doesn't exist in column A
If loopcount = 0 Then GoTo NotFound
'For each time the target value was found, check the cell in column C. If it's not blank, increment "result"
For counter = 1 To loopcount
Set nextcell = Sheets("Sheet2").Range("A:A").Find(what:=findtext, lookat:=xlWhole, after:=foundcell)
If nextcell.Offset(0, 2).Value <> "" Then
result = result + 1
End If
Set foundcell = nextcell
Next
'Put the result in column B of Sheet1
NotFound:
cell.Offset(0, 1).Value = result
Blanks:
Next
End Sub