I am using VBA to write a Macro and it is working exactly as I want, except that I would like my formulas to loop through the sheets instead of using data on 'SAFO-1', 'SAFO-1' refers to the fish Salvelinus fontinalis (SAFO). I have many fish species (e.g., Morone saxatilis (MOSA)) and it would be way more pratical if I could refer to the sheet number instead of their name. Unfortunately, I do not decide sheet names and they have to stay as they are because we're working on shared projects with unique name for every samples. Sheets name change between projects and I want to be able to use my code in all of them. Here is my current code:
Sub Mean()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Sheet As Integer
k = 4
i = Application.Sheets.Count
For Sheet = 2 To i
Worksheets(Sheet).Select
j = 3
Do While ActiveCell.Value <> "0"
Range("A" & j).Select
If ActiveCell.Value = "0" Then
Range("A1").Copy
Worksheets("Mean").Range("A" & Sheet + 1).PasteSpecial Paste:=xlPasteValues
Worksheets("Mean").Range("B" & Sheet + 1).Formula = "=(('SAFO-1'!B80)-('SAFO-1'!B75))"
Worksheets("Mean").Range("C" & Sheet + 1).Formula = "=(('SAFO-1'!C80)-('SAFO-1'!C75))"
For k = 4 To 41
Worksheets("Mean").Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('SAFO-1'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Next k
Else
j = j + 1
End If
Loop
Next Sheet
Range("B1:AP2").Copy Worksheets("Mean").Range("A1")
Worksheets("Mean").Select
End Sub
My idea is to replace 'SAFO-1' by 'Sheet1', to be enventually able to write something like :
Worksheets("Mean").Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('Sheet "& Sheet")'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Thanks in advance!
William Fortin
First, we are going to stop using .Select and instead use object handles. I'm not entirely sure where the name of your sheet comes from but I'm going to assume that it's related to the loop and use that as an example. We get an object handle on the sheet using it's number Set currentSheet = Worksheets(Sheet) and then we can grab it's name and use that where we need to in the formula currentSheet.Name.
I hope that even if this code isn't a complete solution that it shows you how to get where you are going.
Option Explicit
Public Sub Mean()
Dim j As Long
Dim k As Long
Dim Sheet As Long
k = 4
For Sheet = 2 To Application.Sheets.Count
Dim currentSheet As Worksheet
Set currentSheet = Worksheets(Sheet)
j = 3
Do
Dim currentCell As Range
Set currentCell = currentSheet.Range("A" & j)
If currentCell.Value = "0" Then
With Worksheets("Mean")
.Range("A" & Sheet + 1).Value = currentSheet.Range("A1").Value
.Range("B" & Sheet + 1).Formula = "=(('" & currentSheet.Name & "'!B80)-('" & currentSheet.Name & "'!B75))"
.Range("C" & Sheet + 1).Formula = "=(('" & currentSheet.Name & "'!C80)-('" & currentSheet.Name & "'!C75))"
For k = 4 To 41
.Cells(Sheet + 1, k).FormulaR1C1 = "=AVERAGE('" & currentSheet.Name & "'!R" & j + 10 & "C" & k & ":R" & j - 9 & "C" & k & ")"
Next k
End With
Else
j = j + 1
End If
Loop While currentCell.Value <> "0"
Next Sheet
currentSheet.Range("B1:AP2").Copy Worksheets("Mean").Range("A1")
Worksheets("Mean").Select
End Sub
We can create an array of worksheet names in VBA and use them to create the formulas we put in the sheets. For example:
Sub useNumber()
sh = Array("big worksheet name", "collosal worksheet name", "mammoth worksheet name", "tiny worksheet name")
Sheets("Sheet1").Range("A1").Formula = "=SUM('" & sh(1) & "'!A3:A6)"
End Sub
If you have many sheets, use a For loop to fill the array rather than the Array() function.
running this creates:
=SUM('collosal worksheet name'!A3:A6)
In Sheet1 cell A1
This approach makes looping over data sheets easier:
Sub useNumberloop()
sh = Array("big worksheet name", "collosal worksheet name", "mammoth worksheet name", "tiny worksheet name")
For i = 1 To 4
Sheets("Sheet1").Range("A" & i).Formula = "=SUM('" & sh(i - 1) & "'!A3:A6)"
Next i
End Sub
I wrote a piece of VBA code that was working before, but it gets error 1004 on name/xvalue/value recently. I am using excel 2010.
Sub LineChartTemp()
Dim i As Integer, j As Integer, k As Integer
' i = series, j = start row, k = end row
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
Dim chart As chart
Set chart = ActiveChart
For i = 1 To 156
j = (i - 1) * 13 + 1 + 1
k = j + 12
' two 1, one for name row, one for the minus 1, 13 is number of data points of each series
chart.SeriesCollection.NewSeries
chart.SeriesCollection(i).Name = "=" & ActiveSheet.Name & "!$A$" & j & ":$C$" & j
chart.SeriesCollection(i).XValues = "=" & ActiveSheet.Name & "!$D$" & j & ":$D$" & k
chart.SeriesCollection(i).Values = "=" & ActiveSheet.Name & "!$E$" & j & ":$E$" & k
Next i
End Sub
I am working on an accounting VBA program that will post Journal entries to a Ledger, and then generate trial balances (i.e. print out the values on a new sheet following "Bal. " in the Ledger). To do this, I need a way to assign the numerical part of the balance cells to a variable or collection. Unfortunately, when I use Debug.Print I see the only value stored is 0 (I am testing just with Common Stock). My expression is: y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])") where y represents the balance of Common Stock. How do I properly store the balance value in a variable?
' TODO BE ABLE TO RUN MULTIPLE TIMES
' CHECK FOR POSTED MARK & START WRITING WHEN
' r = "one of the keys", or just creates new Ledger Worksheet every time
Sub MacCompileData()
Application.ScreenUpdating = False
Dim lastRow As Long, x As Long
Dim data, Key
Dim r As Range
Dim cLedger As Collection, cList As Collection
Set cLedger = New Collection
With Worksheets("Journal")
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For x = 2 To lastRow
Key = Trim(.Cells(x, 2))
On Error Resume Next
Set cList = cLedger(Key)
If Err.Number <> 0 Then
Set cList = New Collection
cLedger.Add cList, Key
End If
On Error GoTo 0
cLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Worksheets("Journal").Cells(x, 5).Value = ChrW(&H2713)
Next
End With
With Worksheets("Ledger")
Dim IsLiability As Boolean
Dim y As Integer
For Each r In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
If r <> "" Then
On Error Resume Next
Key = Trim(r.Text)
If Key = "LIABILITIES" Then
IsLiability = True
End If
data = getLedgerArray(cLedger(Key))
If Err.Number = 0 Then
Set list = cLedger(Key)
x = cLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = data
If IsLiability Then
.Offset(0, 2).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
' LOOK HERE FOR Y
y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])")
Debug.Print "Common Stock Balance Equals "; y
Else
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
End If
r.Offset(1).EntireRow.Delete
End With
End If
On Error GoTo 0
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getLedgerArray(c As Collection)
Dim data
Dim x As Long
ReDim data(1 To c.Count, 1 To 3)
For x = 1 To c.Count
data(x, 1) = c(x)(0)
data(x, 2) = c(x)(1)
data(x, 3) = c(x)(2)
Next
getLedgerArray = data
End Function
Here is a solution that I was able to figure out, though I am not sure if it is the most efficient. In line before the formula is set, I set a Range named BalanceCell to the cell where the formula will be written. I then used the Mid Function to get the string number value from the cell (since the length of "Bal. " is always 5 characters) after the formula is put into BalanceCell.
If IsLiability Then
Set BalanceCell = .Offset(0, 2).Resize(1, 1)
BalanceCell.FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
y = Mid(BalanceCell.Value, 6, Len(BalanceCell.Value))
Debug.Print "Common Stock Balance is "; y
I have the following VBA code:
Sub test():
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")
GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
To break down what this code does:
1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.
2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.
3) Repeat until there are no more entries.
I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.
Can anyone point me to what I would need to change in order to do this (and preferably why)?
In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?
Removed Line continuations in code:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:
INPUT
A 1
B
y 3
z 4
t
d
s 7
C 8
A 1
Z
y 3
z 4
t
d
s 7
C 12
OUTPUT
B 8
Z 12
.
.
.
Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
'assuming your string is in column A
If w1.Range("A" & i) = "FIND ME" Then
newValue = w1.Range("A" & i).Offset(1,0).Value
End If
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue
UPDATED ANSWER
I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.
To search a range for your search string, you need to set up a range you are looking in:
dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row
Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.
dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")
with searchRange
set c = .Find("A", lookin:=xlValues)
set d = .Find("C", lookin:=xlValues)
if not c Is Nothing and not d Is Nothing then
cAddress = c.address
dAddress = d.address
resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
Do
set c = .FindNext(c)
set d = .FindNext(d)
Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
end if
end with
Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.
dim outRange as range
dim item as variant
set outRange = w2.Range("A1")
for each item in resultsDictionary
outRange.Value = item.key
set outRange = outRange.Offset(0,1)
outRange.Value = item.item
set outRange = outRange.Offset(1,-1)
next item
Can anyone point me to what I would need to change in order to do this
(and preferably why)?
Basically you need to change the parts of which NameValue is composed.
Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).
Originally it was:
Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
Now you need something like this:
Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))
In addition, how might I be able to extend this code to run over
multiple sheets while depositing the results in a single sheet?
(with output sheet w_n possibly in a different workbook)?
To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.
' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))
' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
' Finally set the second sheet where the results should be appended
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")
' Or set the second sheet where the results should be appended to sheet
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
The complete code might look like this (tested with data you provided).
Option Explicit
Public Sub main()
' String to search below of it
Dim string1 As String
string1 = "A"
' String to search beside of it
Dim string2 As String
string2 = "C"
' Set the sheets that should be searched
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))
' Set the second sheet (outputSheet sheet) that the results should be
' appended to external sheet in different book
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
SearchFor string1, string2, searchedSheets, outputSheet
End Sub
Public Sub SearchFor( _
string1 As String, _
string2 As String, _
searchedSheets As Sheets, _
output As Worksheet)
Dim searched As Worksheet
Dim NameValue As String
Dim below As String
Dim beside As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim rowsCount As Long
For Each searched In searchedSheets
rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rowsCount
' Search the first column for a 'string1'
If searched.Range("A" & i) = string1 Then
' once 'string1' was found grab the entry directly below it
below = searched.Range("A" & i + 1)
If InStr(1, NameValue, below) Then
' skip this 'below' result because it was found before
GoTo GetNext
End If
' Search the first column for a 'string2' starting at the
' position where 'below' was found
For j = i + 1 To rowsCount
If searched.Range("A" & j) = string2 Then
' once 'string2' was found grab the entry directly
' beside it
beside = searched.Range("B" & j)
Exit For
End If
Next j
' Append 'below' and 'beside' to the result and count the
' number of metches
NameValue = Trim(NameValue & " " & below & "|" & beside)
c = c + 1
End If
GetNext:
Next i
Next searched
' Write the output
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
output.Range("A" & k) = Left(NameValue, i - 1)
output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.
Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.
To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!
Option Explicit
Sub Test()
Dim src As Worksheet, dst As Worksheet
Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
If src.Name = dst.Name Then GoTo SkipNext
NamesToList src, dst
SkipNext:
Next
End Sub
'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")
Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String
On Error GoTo Err_NamesToList
Set dic = New Dictionary
i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
If srcWsh.Range("A" & i) = SearchFor Then
sKey = srcWsh.Range("B" & i)
If Not dic.Exists(sKey) Then
Do While srcWsh.Range("A" & i) <> ThenNextFor
i = i + 1
Loop
sVal = srcWsh.Range("B" & i)
dic.Add sKey, sVal
k = GetFirstEmpty(dstWsh)
With dstWsh
.Range("A" & k) = sKey
.Range("B" & k) = sVal
End With
'sKey = ""
'sVal = ""
End If
End If
SkipNext:
i = i + 1
Loop
Exit_NamesToList:
On Error Resume Next
Set dic = Nothing
Exit Sub
Err_NamesToList:
Resume Exit_NamesToList
End Sub
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
Sample output:
Name DateOfBirth:
A 1999-01-01
B 1999-01-02
C 1999-01-03
D 1999-01-04
E 1999-01-05
I want to loop through an entire column W2, while taking the average of each row. the column is 1326 long.
The code I have below only calculates the average of W2 and B2. Can someone help
NumCellsFromEdge = 3
Dim NumOfCells As Integer
NumOfCells = 3
MsgBox GetTopDrTS(NumCellsFromEdge, NumOfCells) & " = average of " & NumCellsFromEdge & " cells in, and " & NumOfCells & " cells wide"
End Sub
Function GetTopDrTS(L_NumCellsFromEdge As Integer, L_NumOfCells As Integer) As Double
Dim val As Double
Dim mycol As Double
val = 0
mycol = 23
'Range("W2").Select
'Columns(mycol).Select
Dim i As Integer
For i = 0 To L_NumOfCells - 1
Range("W2" & i).Select
val = val + Selection.Worksheet.Cells(Selection.Row, Selection.Column + EdgePos + L_NumCellsFromEdge + i).Value
Next i
GetTopDrTS = val / L_NumOfCells
End Function
This is all you need:
MsgBox [average(w:w)]
Application.average(sheets(1).range("E:E"))
will tell you the average of column E in sheets 1