Updating Alternative text of a button - vba

I have the following code as part of a Job site labor form, which links a full labor call on the "LocLabor" sheet to various single day sign in sheets. This particular code is to add a complete day to the form, and works great, with the exception of these two lines at the bottom:
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
The "scopy", "ecopy", and "brow" variables are used to work out the appropriate lines to copy and paste to the next day. The buttons that are being altered are the newly pasted buttons that were copied within the scopy/ecopy range and are used to add or delete a line from the table they refer to. I need to be able to change the AltText because I am using that as a reference for which day of the labor call they apply to. The "numdays" variable pulls from locsht.Range("L3").Value, which is set to the current number of days on the form prior to running the macro. So it would have a value of 2 when I see the error
Now to the issue - if I have two days existing in the document and I execute the below code, the name of the button changes, but the Alternative Text does not (it remains as "2" or whatever it was prior to copying). Days 4 and up work perfectly though, it is just the transition from day 2 to 3 that I cannot get to work! It also works if I switch out "dayint + 1" to a string, like "banana" for example, but that obviously doesn't help me.
Any ideas would be appreciated.
Option Explicit
Sub add_day()
Dim numdays As String
Dim tbl As TableStyle
Dim newsht As Worksheet
Dim locsht As Worksheet
Dim scopy As Integer
Dim ecopy As Integer
Dim brow As Integer
Dim dayint As Integer
Dim bnum As Integer
Dim tblstart As String
Application.ScreenUpdating = False
'unlock sheet
Worksheets("LocLabor").Unprotect Password:=SuperSecretPW
'set/get variables
Set locsht = Worksheets("LocLabor")
numdays = locsht.Range("L3").Value
dayint = numdays
Worksheets("Labor Sign In Day " & numdays).Copy Before:=Sheets(numdays + 4)
Worksheets("Labor Sign In Day " & numdays & " (2)").Name = "Labor Sign In Day " & numdays + 1
'update number of days on sheet
locsht.Range("L3") = locsht.Range("L3").Value + 1
'rename new sign in sheet
Set newsht = Worksheets("Labor Sign In Day " & numdays + 1)
newsht.Unprotect Password:=SuperSecretPW
'figure out which rows to copy on main sheet
scopy = locsht.ListObjects(dayint).Range.Rows(1).Row - 1
brow = locsht.ListObjects(dayint).Range.Rows.Count
ecopy = scopy + brow
'Copy/paste new day on LocLabor
locsht.Activate
locsht.Rows(scopy & ":" & ecopy).Copy
locsht.Rows(ecopy + 2).Insert Shift:=xlDown
locsht.ListObjects("Tableday" & numdays).Resize Range("A" & scopy + 1 & ":" & "H" & ecopy)
locsht.Range("A" & ecopy + 2 & ":" & "H" & ecopy + 2) = "=IFERROR($A$17+" & numdays & "," & """Enter Load in Date at Top"")"
locsht.Rows(ecopy + 1).EntireRow.Delete
locsht.PageSetup.PrintArea = "$A$1:$H$" & ecopy + (ecopy - scopy + 1)
locsht.HPageBreaks.Add Before:=locsht.Rows(ecopy + 1)
locsht.ListObjects(dayint + 1).Name = "Tableday" & numdays + 1
bnum = (dayint * 2) + 3
tblstart = locsht.ListObjects(dayint + 1).Range.Rows(1).Row + 1
'Enter correct formulas into sign in sheet
With newsht
.ListObjects(1).Name = "signinday" & numdays + 1
.Range("i12") = Left(newsht.Range("i12").Formula, 28) & numdays & Right(newsht.Range("i12").Formula, 48)
.Range("A17") = "=IF(ISBLANK(LocLabor!G" & tblstart & ")=FALSE,LocLabor!G" & tblstart & "&"" ""&LocLabor!F" _
& tblstart & ",IF(ISBLANK(LocLabor!D" & tblstart & ")=TRUE," & """""" & ",LocLabor!D" & tblstart & "))"
.Range("B17") = "=IF(ISBLANK(LocLabor!B" & tblstart & ")=TRUE, """", LocLabor!B" & tblstart & ")"
.Range("G17") = "=IF(ISBLANK(LocLabor!C" & tblstart & ")=TRUE, """", LocLabor!C" & tblstart & ")"
End With
'rename pasted buttons, update alttext
With locsht
.Buttons(bnum).Name = "Button " & bnum
.Buttons(bnum + 1).Name = "Button " & bnum + 1
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
End With
'lock down sheets
Worksheets("LocLabor").Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("LocLabor").EnableSelection = xlUnlockedCells
Worksheets("Labor Sign In Day " & numdays + 1).Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("Labor Sign In Day " & numdays + 1).EnableSelection = xlUnlockedCells
ActiveSheet.Buttons(Application.Caller).TopLeftCell.Offset(3, 0).Select
Application.ScreenUpdating = True
End Sub

Related

Run-time error 5 : Invalid procedure call or argument

I've got the below code and it works completely fine for rows 1 - 46 on it's own populating one table. As soon as I replicate this with a second table to populate it throws Error1.
I've taken out everything below "' Second Table Entry " and works fine ... put back in and same error. On the "Home" sheet it actually populates the tables information but still throws the error which is stopping further vba from executing.
Any ideas? I've been all over google, stackoverflow, superuser and Microsoft MSDN and can't figure out where in the second bit of code is causing it to error.
EDIT: I've checked the debugger and it's highlighting the below code in the second table inserts
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("H" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("Audit_InFlight").Range("D" & i).Value
End With
Any help is greatly appreciated.
Error1
Run-time error '5': Invalid procedure call or argument
Private Sub Workbook_Open()
Dim row_ptr As Long
Dim i As Long
Dim i2 As Long
Dim rownbrMA_Inflight As Long
Dim rownbrAudit As Long
Dim CurrentWorkbook As Workbook
Dim InputWorksheet As Worksheet
Dim DataSourceWorksheet As Worksheet
Dim AuditDataSourceWorksheet As Worksheet
Set CurrentWorkbook = Workbooks(ActiveWorkbook.Name)
Set InputWorksheet = CurrentWorkbook.Sheets("Home")
Set DataSourceWorksheet = CurrentWorkbook.Sheets("MA_Inflight")
Set AuditDataSourceWorksheet = CurrentWorkbook.Sheets("Audit_InFlight")
InputWorksheet.Range("A30:M176").Clear
InputWorksheet.Range("A30:M176").ClearFormats
InputWorksheet.Range("A30:M176").Interior.Color = RGB(255, 255, 255)
rownbrMA_Inflight = DataSourceWorksheet.Range("C" & Rows.Count).End(xlUp).Row
row_ptr = 31
For i = 8 To rownbrMA_Inflight
If DataSourceWorksheet.Range("C" & i).Value = "Open" Then
InputWorksheet.Rows(row_ptr).Insert Shift:=xlDown 'CopyOrigin:=xlFormatFromLeftOrAbove
InputWorksheet.Range("A" & row_ptr).Value = DataSourceWorksheet.Range("E" & i).Value
InputWorksheet.Range("B" & row_ptr).Value = DataSourceWorksheet.Range("F" & i).Value
AddStr = "MA_Inflight!" & "$F$" & CStr(i)
ActiveWorkbook.Activate
Worksheets("Home").Activate
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("B" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("MA_Inflight").Range("F" & i).Value
End With
InputWorksheet.Range("C" & row_ptr).Value = DataSourceWorksheet.Range("I" & i).Value
InputWorksheet.Range("D" & row_ptr).Value = DataSourceWorksheet.Range("J" & i).Value
InputWorksheet.Range("E" & row_ptr).Value = DataSourceWorksheet.Range("L" & i).Value
row_ptr = row_ptr + 1
End If
Next i
'============================================================
' Second Table Entry
'============================================================
rownbrAudit = DataSourceWorksheet.Range("C" & Rows.Count).End(xlUp).Row
row_ptr = Empty
row_ptr = 31
For i = 8 To rownbrAudit
If AuditDataSourceWorksheet.Range("B" & i).Value <> "Closed" Then
InputWorksheet.Rows(row_ptr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
InputWorksheet.Range("G" & row_ptr).Value = AuditDataSourceWorksheet.Range("B" & i).Value
InputWorksheet.Range("H" & row_ptr).Value = AuditDataSourceWorksheet.Range("D" & i).Value
'New code ---------------------------
AddStr = "Audit_InFlight!" & "$D$" & CStr(i)
ActiveWorkbook.Activate
Worksheets("Home").Activate
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("H" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("Audit_InFlight").Range("D" & i).Value
End With
'-----------------------------------
InputWorksheet.Range("I" & row_ptr).Value = AuditDataSourceWorksheet.Range("G" & i).Value
InputWorksheet.Range("J" & row_ptr).Value = AuditDataSourceWorksheet.Range("H" & i).Value
InputWorksheet.Range("K" & row_ptr).Value = AuditDataSourceWorksheet.Range("I" & i).Value
InputWorksheet.Range("L" & row_ptr).Value = AuditDataSourceWorksheet.Range("J" & i).Value
InputWorksheet.Range("M" & row_ptr).Value = AuditDataSourceWorksheet.Range("K" & i).Value
row_ptr = row_ptr + 1
End If
Next i
'RemoveBlankCells
'PURPOSE: Deletes single cells that are blank located inside a designated range
Dim rng As Range
'Store blank cells inside a variable
Set rng = InputWorksheet.Range("A30:E50").SpecialCells(xlCellTypeBlanks)
'Delete blank cells and shift upward
rng.Rows.Delete Shift:=xlShiftUp
End Sub

Get data type from closed workbook cell and vary action accordingly

I'm collecting metric values from many different worksheets in one overview sheet which will be used for generating a PowerBI dashboard.
Below is my code, i'm new to vba so it's probably not so elegant, but works for what i need, except for one thing.
Some of the metric values in these sheets are integers, others have data type percentage.
If the value in the metric sheet has number format %, for example "10" formatted as %, it gets taken as 0,1 with the current code i have. I would like to multiply these percentages with 100 and add this number in the overview sheet. But I have difficulties finding out how i can extract the data type and if a percentage, multiply with 100, and if no percentage, get the value as is. Would anyone be able to help with that?
Many thanks in advance -
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err.Number <> 0 Then
HasSheet = False
End If
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim id As Integer
Dim Ind As String
Dim MetricName As String
Dim Include1 As String
Dim Include2 As String
Dim Segment As String
Dim file As String
Dim filepath As String
Dim filename As String
Dim s As Boolean
Dim D As Date
Dim MonthNbr As Integer
Set sh1 = Worksheets("Metrics")
Set sh2 = Worksheets("Metadata")
NumRows = sh1.Range("A1", sh1.Range("A1").End(xlDown)).Rows.Count
For id = 2 To NumRows
MetricName = sh1.Range("A" & id).Value
Include1 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
filename = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = sh1.Range("B" & id).Value
file = "='https://xxx/[" & filename & "]" & Segment
filepath = "https://xxx/"
s = HasSheet(filepath, filename, Segment)
If s Then
D = sh1.Range("C" & id).Value
MonthNbr = Month(D)
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("J" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("O" & id).Value = "values updated on " & Format(Now(), "dd-mm-yy")
Else
sh1.Range("O" & id).Value = "sheet available but segment missing"
End If
ElseIf Include2 = "no" Then
sh1.Range("O" & id).Value = "metric set to not yet include"
ElseIf Include1 = "manual" Then
sh1.Range("O" & id).Value = "metric to be manually updated"
End If
Next
MsgBox (" Update completed! ")
End Sub
I would try to avoid multiplying a percentage by 100 and adding a percent symbol, if there's the option to do it the "right way".
It's not a huge problem in this case, it's just better to create good habits. (And just for the record, the reason 10% gets taken as 0,1 is because 10% is 0,1.
Nonetheless, we need an easy way to display it as a percentage instead of a fraction of 1 (when applicable), and as with many tasks in Excel, there are multiple ways to accomplish the same thing.
This way took me the least thought:
Range("B1") = Range("A1") 'copies the value
Range("B1").NumberFormat = Range("A1") .NumberFormat 'copies the number format.
Changes I made:
The "cleanest" way to do this was with a small sub called copyNumber and adjusting the affected lines to use the new procedure.
I tidied indentation - which is important for organization and readability.
I added Option Explicit which is a good idea to have at the beginning of every module, to help recognize oversights such as...
sh1 and sh2 were not declared as Worksheets, so I added Dim statements for them - but squished them onto a line shared with their Set statements with : colons.
The other changes I made were purely cosmetic and more of a matter of perference, and obviously if you don't like those changes, don't use them. :-)
I got rid of the ElseIf's - I don't like them for the same reason indentation is important.
I used With..End statements to remove repetitive code (like Sh1. and Application.WorksheetFunction.)
I squished the variable declaration (Dim statements) from "a page" into 3 lines.
Adjusted Code:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub copyNumber(rgeSrc As Range, rgeDest As Range)
rgeDest.Value = rgeSrc.Value ' copy number
rgeDest.NumberFormat = rgeSrc.NumberFormat ' copy number format
End Sub
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxx/[" & fileName & "]" & Segment
filePath = "https://xxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
copyNumber .Range("D" & id), Range(file & "'!D" & (MonthNbr + 13))
copyNumber .Range("E" & id), Range(file & "'!E" & (MonthNbr + 13))
copyNumber .Range("F" & id), Range(file & "'!F" & (MonthNbr + 13))
copyNumber .Range("G" & id), Range(file & "'!G" & (MonthNbr + 13))
copyNumber .Range("J" & id), Range(file & "'!D" & (MonthNbr + 40))
copyNumber .Range("K" & id), Range(file & "'!E" & (MonthNbr + 40))
copyNumber .Range("L" & id), Range(file & "'!F" & (MonthNbr + 40))
copyNumber .Range("M" & id), Range(file & "'!G" & (MonthNbr + 40))
Range("O" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
Else
Range("O" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("O" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("O" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub
Just in case someone is looking for this approach in future, here is the final code i used:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String, Include3 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Include3 = .VLookup(MetricName, sh2.Range("B2:L100"), 11, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxxx/[" & fileName & "]" & Segment
filePath = "https://xxxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("H" & id).Value = file & "'!B" & (MonthNbr + 13) 'Actuals KPI Index
Select Case sh1.Range("H" & id).Value
Case "R"
sh1.Range("H" & id).Value = "3"
Case "Y"
sh1.Range("H" & id).Value = "2"
Case "G"
sh1.Range("H" & id).Value = "1"
End Select
sh1.Range("I" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("J" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!B" & (MonthNbr + 13) 'YTD KPI Index
Select Case sh1.Range("M" & id).Value
Case "R"
sh1.Range("M" & id).Value = "3"
Case "Y"
sh1.Range("M" & id).Value = "2"
Case "G"
sh1.Range("M" & id).Value = "1"
End Select
Range("N" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
If Include3 = "%" Then ' multiply with 100 for percentages
sh1.Range("D" & id).Value = (sh1.Range("D" & id).Value) * 100
sh1.Range("E" & id).Value = (sh1.Range("E" & id).Value) * 100
sh1.Range("F" & id).Value = (sh1.Range("F" & id).Value) * 100
sh1.Range("G" & id).Value = (sh1.Range("G" & id).Value) * 100
sh1.Range("I" & id).Value = (sh1.Range("I" & id).Value) * 100
sh1.Range("J" & id).Value = (sh1.Range("J" & id).Value) * 100
sh1.Range("K" & id).Value = (sh1.Range("K" & id).Value) * 100
sh1.Range("L" & id).Value = (sh1.Range("L" & id).Value) * 100
End If
Else
Range("N" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("N" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("N" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub

How to dynamically change range inside formula?

I’m applying a formula:
Textual representation of formula:
=(SUBSTITUTE((LEFT(A2;(FIND("htt";A2;1))-3));";";";"))&RIGHT(A2;(LEN(A2)-(FIND("htt";A2;1))+3))
to all cells in a range A2:A10, writing a result to range B2:B10 respectively.
To do this I use the following macro:
Sub ColumnsFormat()
Dim s As String
Dim i As Integer, j As Integer
'Set wb = Workbooks("CSV_File.xlsm")
Application.ScreenUpdating = False
j = 1
For i = 2 To 10
s = "=(SUBSTITUTE((LEFT(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],(FIND(""htt"",R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],1))-3)),"","","";""))&RIGHT(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],(LEN(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "])-(FIND(""htt"",R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],1))+3))"
Sheets("Sheet1").Cells(i, 2).Value = s
Next i
End Sub
The problem is that for some reason a row number inside the formula inside a For cycle is wrong. Instead of taking A2; A3; A4 … A10 cells, (changing row number by 1 each time), macro runs through A2; A4; A6 etc. (increasing a row number by 2 each time).
What am I doing wrong?
By changing the row in the formula to 0 the code works just fine. I guess the problem is that in your formula the row was calculated relative to the specific cell the formula was afterwards applied to. Therefore the formula in B2 looked at A(2+2), in B3 at A(3+3) and so on.
Sub ColumnsFormat()
Dim s As String
Dim i As Integer, j As Integer
'Set wb = Workbooks("CSV_File.xlsm")
Application.ScreenUpdating = False
j = 1
For i = 2 To 10
s = "=(SUBSTITUTE((LEFT(R[" & 0 & "]C[" & j - 2 & "],(FIND(""htt"",R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],1))-3)),"","","";""))&RIGHT(R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],(LEN(R[" & 0 & "]C[" & Trim(Str(j - 2)) & "])-(FIND(""htt"",R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],1))+3))"
Sheets("Sheet1").Cells(i, 2).Value = s
Next i
End Sub

VBA Excel Macro -How to repeat the macro for each sheet?

I have pieced together this macro VBA that works perfectly. However, I need to run the same code on multiple sheets in the same workbook. I've tried many things i've seen online (SubWorksheetLoop2, etc) and am having no luck. The goal is to use this code below and have it run through all the pages of my workbook. The names of my tabs are 'CLASS II', 'CLASS III', etc. Please advise!
Option Explicit
Sub InsertBetweenV3()
Dim Area As Range
Dim r As Long, lr As Long, sr As Long, er As Long, i
enter code here
' turn off screen updating
Application.ScreenUpdating = False
enter code here
' create an array to fill the 6 inserted rows
i = Array("", "OBS", "VIOL", "VIOL RATE", "STATEMENT", "")
enter code here
enter code here
' activate/select the first worksheet
Worksheets(1).Activate
enter code here
' lr is for last row. Find the last row in column 1 = column A
lr = Cells(Rows.Count, 1).End(xlUp).Row
' when we are inserting/deleting rows we usually start from the bottom up
For r = lr To 3 Step -1
' Range("A" & r) is not equal to Range("A" & r - 1)
' If A1535 is not equal to A1534 Then
If Cells(r, 1) <> Cells(r - 1, 1) Then
' insert 6 rows
Rows(r).Resize(6).Insert
End If
Next r
' now that we have inserted six empty rows for each change in STATION
' find the new last row in column 1 = column A
lr = Cells(Rows.Count, 1).End(xlUp).Row
' for each Area in range A1:A new last row
' Area will find each group of rows between the inserted 6 rows
For Each Area In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
' with each Area
With Area
' sr a variable for start row
' the .Row of the Area is the first row of the Area sr = .Row
sr = .Row
' er a variable for end row
' is equal to sr + count of rows in the Area – 1
' er = sr + .Rows.Count – 1
er = sr + .Rows.Count - 1
' beginning in the blank inserted 6 rows
' transpose the i array vertically
Cells(er + 1, 1).Resize(6).Value = Application.Transpose(i)
' in the first blank row change the interior color to Gray
' from column 1 = column A to column 46 = column AT
Cells(er + 1, 1).Resize(, 68).Interior.ColorIndex = 15
' bold the text inserted from the i array
Cells(er + 2, 1).Resize(4).Font.Bold = True
' in the last blank row change the interior color to Gray
' from column 1 = column A to column 46 = column AT
Cells(er + 6, 1).Resize(, 68).Interior.ColorIndex = 15
' put the formula in the appropriate cells to do the calculations
Range("G" & er + 2).Formula = "=COUNTIF(G" & sr & ":G" & er & ","">0"")"
Range("G" & er + 3).Formula = "=SUM(COUNTIF(G" & sr & ":G" & er & ", ""<6""),COUNTIF(G" & sr & ":G" & er & ","">9""),-COUNTIF(G" & sr & ":G" & er & ",""=0""))"
Range("G" & er + 4).Formula = "=(G" & er + 3 & "/G" & er + 2 & ")*100"
Range("K" & er + 2).Formula = "=COUNTIF(K" & sr & ":K" & er & ","">0"")"
Range("K" & er + 3).Formula = "=COUNTIF(K" & sr & ":K" & er & ","">32"")
Range("K" & er + 4).Formula = "=(K" & er + 3 & "/K" & er + 2 & ")*100"
Range("I" & er + 2).Formula = "=COUNTIF(I" & sr & ":I" & er & ","">0"")"
Range("I" & er + 3).Formula = "=SUM(COUNTIF(I" & sr & ":I" & er & ",""<4""),-COUNTIF(I" & sr & ":I" & er & ",""=0""))"
Range("I" & er + 4).Formula = "=(I" & er + 3 & "/I" & er + 2 & ")*100"
Range("S" & er + 2).Formula = "=COUNTIF(S" & sr & ": S" & er & ","">0"")"
Range("S" & er + 3).Formula = "=COUNTIF(S" & sr & ": S" & er & ","">235"")"
Range("S" & er + 4).Formula = "=(S" & er + 3 & "/ S" & er + 2 & ")*100"
Range("U" & er + 2).Formula = "=COUNTIF(U" & sr & ":U" & er & ","">0"")"
Range("U" & er + 3).Formula = "=COUNTIF(U" & sr & ":U" & er & ","">104"")"
Range("U" & er + 4).Formula = "=(U" & er + 3 & "/U" & er + 2 & ")*100"
End With
Next Area
' find the last row in column 1 = column A
lr = Cells(Rows.Count, 1).End(xlUp).Row
' in the following ranges change the number format
Range("G2:G" & lr).NumberFormat = "0.000"
Range("K2:K" & lr).NumberFormat = "0.000"
Range("S2:S" & lr).NumberFormat = "0.000"
Range("U2:U" & lr).NumberFormat = "0.000"
' turn back on screen updating
Application.ScreenUpdating = True
End Sub
Worksheets can be identified by their Worksheet .CodeName property, Worksheet .Name property or Worksheet.Index property among others.
A large number of worksheets with a small number of exclusions is probably best sought after with an index based loop.
dim w as long
for w = 1 to worksheets.count
with worksheets(w)
if .name <> "Master" and .name <> "Summary" then
'do some stuff with the worksheet(s)
end if
end with
next w
If you have a limited number of specific worksheets, then the .name(s) can be put into an array.
dim v as long, vWSs as variant
vWSs = array("CLASS II", "CLASS III", "CLASS IV")
for v = lbound(vWSs) to ubound(vWSs)
with worksheets(vWSs(v))
'do some stuff with the worksheet(s)
end with
next v
Those are two methods that work well in different situations. The worksheet codename is best for referencing worksheets abstractly; perhaps as a destination to a copy/paste from within one of the above loops.
While not as elegant or dynamic as other methods, you could use a simple For loop:
For iCount = 1 to 99 'number of Worksheets
Worksheets(iCount).select
'Insert your code here
Next

Copy data to new workbook and add specific text to each row´s value in a specific column

I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.