I am trying to activate numerous tabs named for example I have a tab named "95004700" I reference these codes in a list then seek to activate the corresponding tab (I set them = to the variable STRcode). For some reason I constantly get an out of range error at "worksheets(STRcode).Activate
"could someone explain to me why? I feel like it may have something to do with the formatting of the cell I am referencing or the method that I have set the variable with.
Sub Budget_Actual()
Dim DBLdatarow As Double
Dim STRcode As Long
Dim STRname As String
Dim cell As Range
DBLdatarow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row - 1
'loop #1
Do While DBLdatarow > 5
STRcode = Range("D" & DBLdatarow).Value
STRname = Range("B" & DBLdatarow).Value
Workbooks.Open Filename:="File Path"
Worksheets(STRcode).Activate
Columns("B:B").Select
Set cell = Selection.Find(What:=STRname, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
DBLdatarow = DBLdatarow + 1
Loop
'loop #1
End Sub
Simply pass a string:
Worksheets(cstr$(STRcode)).Activate
As passing an integer attempts to open the 95004700th sheet (based on the fact that Worksheets(1) is another way of addressing the first sheet and Worksheets("1") addresses a sheet named "1").
Sheets(STRcode).Activate activates Worksheet number STRcode. While you probably want to activate Worksheet with the name STRcode.
Excel can't handle 95004700 sheets.
You need to change STRcode from Integer to String.
Related
I have a requirement to automate a step to copy data from one sheet to another using excel macro.
But below are the problem I am facing with this requirement:
Need to copy paste in scope data i.e. filter on 'Data Scope' = Yes
Column sequence of source and target are different and since there are around 127 columns so could not hardcode this part.
Please help if you have a handy code or logic to implement the same.
Found a simple way to implement this, posting it here for others to use.
Sub Reorganize_columns()
Dim v As Variant, x As Variant, findfield As Variant
Dim oCell As Range
Dim rng As Range
Dim iNum As Long
Dim sht_source As Worksheet, sht_target As Worksheet
Set sht_source = ActiveWorkbook.Sheets("Data")
Set sht_target = ActiveWorkbook.Sheets("Macro")
sht_source.Range("A1").AutoFilter Field:=1, Criteria1:="Yes"
Set rng = sht_target.Range("A1:HS1")
For Each cell In rng
iNum = iNum + 1
findfield = cell.Value
Set oCell = sht_source.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
sht_source.Columns(oCell.Column).Copy
sht_target.Columns(iNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next cell
ActiveWorkbook.Save
MsgBox "Completed"
End Sub
My macro needs to do some calculations on rows and import data where the user enters an ID. Main thing it's running on the specified ID because there is some data that needs updating/doublechecking so running running the entire source file is not ideal.
My code basically asks the user to enter an ID as 'criteria', and then this gets compared with a dictionary I created containing all data from the source, the problem is that using dict.Item doesn't really compare IDs though it runs on every single row correctly in the destination sheet.
'dictionary filler
For indexsrsrow = 2 To indexsrslastrow
dict.Add CStr(srcWorksheet.Range("A" & indexsrsrow).Value), indexsrsrow
Next indexsrsrow
dim criteria as string
criteria = inputbox("enter id")
For indexdstrow = 2 To indexlastdstrow
'IF ID EXIST AND ITEM = CRITERIA AND C COLUMN IS EMPTY
If dict.Exist(criteria) And destinerow.Cells(indexdstrow, "C") = "" Then
'STUFF HAPPENS HERE
End If
Next indexdstrow
Set dict = Nothing
Is there other way to compare dictionary items with an specified user input?.
Thanks in advance.
#SiddharthRout Kinda, e.g. Im the user and I need to update the record (row) with id 123 so I run the macro, it asks me for the id that I need to update, I input 123 and when I press enter, in the code it should get the id on the source workbook, grab the data and paste it in the destination workbook where the id is 123. Hope this clarifies. –
I have commented the code so you should not have a problem understanding it. Let me know if this is what you want? If not then post your query and I will look at it when I wake up.
Option Explicit
Sub Sample()
Dim srcWorksheet As Worksheet, destinerow As Worksheet
Dim dict As New Dictionary
Dim lRow As Long, i As Long
'~~> Set your source and destination worksheets
Set srcWorksheet = Sheet1
Set destinerow = Sheet2
'~~> Add items to dict from Source worksheet
With srcWorksheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
dict.Add CStr(.Range("A" & i).Value), i
Next i
End With
'~~> Ask user for the criteria
Dim criteria As String
criteria = InputBox("enter id")
'~~> If user presses cancel or item doesn't
'~~> exists in dictionary then exit sub
If criteria = "" Then Exit Sub
If Not dict.Exists(criteria) Then Exit Sub
Dim rngToCopy As Range, aCell As Range
'~~> Find the id in source so we can identify the
'~~> range to copy
With srcWorksheet
Set aCell = .Range("A1:A" & lRow).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data that you want to copy
'~~> is in Col B. If not then change as applicable
Set rngToCopy = .Range("B" & aCell.Row)
End If
End With
Set aCell = Nothing
'~~> Find the id in destinations so we can identify the
'~~> range where we need to copy
With destinerow
Set aCell = .Columns(1).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data WHERE you want to copy
'~~> is in Col C. If not then change as applicable
rngToCopy.Copy .Range("C" & aCell.Row)
End If
End With
End Sub
I'm working on a VBA Macro for a database I have in Excel. I've got one Worksheet that stores information such as names, emails etc. (sadly those are not consistently placed in the same columns across all worksheets, but the email adresses span from "B:F"), this database is split into multiple worksheets. Except all those worksheets, I have also got one other worksheet ("Sheet2" in the code below) that stores all the email addresses that have assigned to my newsletter. (The only information in this sheet are the email addresses in the "A" column).
The VBA I'm working on should loop through all the email adresses that have subscribed to the newsletter ("Sheet2") and check if they're stored in "the database" - in the other sheets as well. If not, then give a warning - write "NOTFOUND" in the cell next to the email.
For some reason, VBA gives me a run-time error "Object doesn't support this property or method" on the row:
With Sheets(sheetIndex).Range("B:F").
Originally I thought that the reason for that is that I have not activated the Sheets, but I'm still getting the error.
The code I came up with so far:
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long
Dim ASheet As Worksheet
Set ASheet = Sheets("Sheet2")
lastRowInteger = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowInteger
scanstring = Sheets("Sheet2").Cells(rowNum, 1).Value
For sheetIndex = 1 To ThisWorkbook.Sheets.Count
Sheets(sheetIndex).Activate
If Sheets(sheetIndex).Name <> "Sheet2" Then
With Sheets(sheetIndex).Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub
Some points:
You should avoid Activate - no need for that.
You should always qualify things like
sheet or range, else Excel will use the active workbook /
sheet, and that is not always what you want.
There is a difference between the Sheets and the Worksheets collection. A Chart-sheet, for example, has no cells and therefore no Range.
You are declaring a variable lastRowIndex but uses lastRowInteger. To avoid such errors, always put Option Explicit at the top of your code.
Change your Sub to
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long, rowNum As Long
Dim ASheet As Worksheet
Set ASheet = ThisWorkbook.Worksheets("Sheet2")
lastRowIndex = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowIndex
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet2" Then
With ws.Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub
I am trying to achieve the following:
I have a VBA button that when clicked, copies the active worksheet and pastes it into a new worksheet (I have this function already working perfectly - see code below).
I then want the newly pasted worksheet to find two specified cells, which contain the texts ("bus start") and ("bus finish") and clear all the contents in the cells that are in between the range of the two specified cells.
The rows are dynamic and will change over time as rows get added and deleted, hence why I cannot define a fixed range. Columns however, will not be deleted or added and therefore will be fixed.
For reference, here is my copy and paste code:
Private Sub WkCapBtn_Click()
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Range("C3").Value = DateAdd("d", 7, ActiveSheet.Range("C3"))
ActiveSheet.Name = Format(ActiveSheet.Range("A1").Value, ("dd-mmm-yy"))
End Sub
My initial thinking was to use a .Find function to locate the specified cells and then use a .Offset to select the cells below and above. Where I am stuck though is actually trying to define the range between the specified cells.
If any additional information is needed, please let me know. Thank you in advance!
I corrected your code a little for the beginning:
Static WsCopy As Worksheet
Static Ws1 As Worksheet
Private Sub WkCapBtn_Click()
Set Ws1 = ThisWorkbook.Sheets("ORIGINALSHEETNAME")
Set WSCopy = Ws1.Copy After:=(ThisWorkbook.Sheets(Sheets.Count))
With WSCopy
.Name = Format(.Range("A1").Value, ("dd-mmm-yy"))
.Range("C3").Value = DateAdd("d", 7, .Range("C3"))
End With
End Sub
For your other sub you could set a variable for the cells containing either "bus start" or "bus finish". Can you try the following code and tell me if it worked?
Private Sub DelBusRange()
Dim BusStart As Range
Dim BusFinish As Range
With WsCopy
Set BusStart = .Find(What:="Bus start", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Set BusFinish = .Find(What:="Bus finish", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
.Range(BusStart, BusFinish).clear
End With
End Sub
Chris Neilson's code did the trick once I changed it around.
Private Sub WkCapBtn_Click()
Dim Ws1 As Worksheet
Dim FindBus1 As String
Dim FindBus2 As String
Dim BusMatch1 As Range
Dim BusMatch2 As Range
Set Ws1 = ActiveSheet
Ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Range("C3").Value = DateAdd("d", 7, ActiveSheet.Range("C3"))
ActiveSheet.Name = Format(ActiveSheet.Range("A1").Value, ("dd-mmm-yy"))
FindBus1 = "Bus Start"
FindBus2 = "Bus Finish"
Set BusMatch1 = ActiveSheet.Cells.Find(FindBus1)
Set BusMatch2 = ActiveSheet.Cells.Find(FindBus2)
ActiveSheet.Range(BusMatch1.Offset(3, 1), BusMatch2.Offset(-2, 1)).ClearContents
End Sub
I am into a situation where I need to copy a range from a excel sheet and paste it to another. I have done the following coding which is going well...
Dim mpn As String
mpn = Application.InputBox(prompt:="Input the MPN column name:")
mpn1 = mpn
mpn2 = mpn1 & ":" & mpn
Set currentSheet = wbSource.Worksheets(1)
lastRow1 = currentSheet.Range(mpn1).End(xlDown).Row
ThisWorkbook.Sheets("Sheet2").Range("F2:F" & lastRow1) = currentSheet.Range(mpn2 & lastRow1).Value
This coding goes perfectly well untill there is any blank cell in the column. Can anyone please help me on this particular situation.
Like I mentioned in the comments above, instead of prompting for the column name, use .Find to locate the column name. What if user types Blah Blah in the input box?
Also as mentioned in comments use xlUp rather than xlDown to find the last row to counter for blank cells and other issues you may face. See this
Is this what you are trying? (Untested)
I have commented the code so you should not having a problem understanding it. But if you do then simply post back :)
Sub Sample()
Dim mpnCol As Long
Dim ColName As String, strSearch As String
Dim aCell As Range
Dim wbSource As Workbook
Dim wbInput As Worksheet, currentSheet As Worksheet
'~~> Change this to the Mpn Header
strSearch = "MPN"
'~~> This you have declared in your code
'~~> Change as applicable
Set wbSource = "Someworkbook"
Set currentSheet = wbSource.Worksheets(1)
Set wbInput = ThisWorkbook.Sheets("Sheet2")
With currentSheet
'~~> Search for the mpn header in row 1. Change as applicable
Set aCell = .Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> Column Number
mpnCol = aCell.Column
'~~> Converting column number to column name
ColName = Split(.Cells(, mpnCol).Address, "$")(1)
'~~> Getting last row
lRow = .Range(ColName & .Rows.Count).End(xlUp).Row
'~~> Checking for excel versions. Comment this if the copying
'~~> will always happen in xl2007+ versions
If lRow > 65536 Then
MsgBox "Are you trying to copy from xl2007 to xl2003?. The number of rows exceed the row limit"
Exit Sub
End If
wbInput.Range("F2:F" & lRow).Value = .Range(ColName & "2:" & ColName & lRow).Value
Else
MsgBox strSearch & " header not found"
End If
End With
End Sub
To copy an entire column, reference your range with the .Columns() function.
You could use something like:
ThisWorkbook.Sheets("Sheet2").Columns("F") =
currentSheet.Columns(mpn1).Value
Another alternative would be to use the .Copy sub and specify a Destination for the copy:
currentSheet.Columns(mpn1).Copy
Destination:=ThisWorkbook.Sheets("Sheet2").Columns("F")
Application.CutCopyMode = false
This answer assumes both workbooks are saved with the same version of Excel. If one workbook is pre-2007, and one is 2007+, then the max number of rows allowed in a sheet will be different.
In that case, copying the entire column is not an option - check out Siddarth's answer for a longer solution to that extra complication. He checks for different number of rows to prevent the error.