I'm working on a code to reference an excel sheet by variable, however i'm stuck on the last step which is selecting the sheet according to the variable text which is the month abbreviation
It was the only way i could proceed to select the desired sheet based on the month index, any other help could be welcomed
Dim DestWS1 As Worksheet
Dim InputValue As Integer
InputValue = InputBox("Please enter your month index number", "Selecting month index to generate your report")
' Print the name of the airport to the Immediate Window(Ctrl + G)
Dim MonthIndexResult As String
MonthIndexResult = _
"=LOOKUP(" & InputValue & ",InputData!R3C17:R14C17,InputData!R3C16:R14C16)"
Set DestWS1 = ThisWorkbook.Sheets(" & MonthIndexResult & ")
DestWS1.Select
it was the only way i could proceed to select the desired sheet based on the month index, any other help could be welcomed
Identify Worksheet By Partial Name
Sub SelectByMonth()
Dim InputString As String
InputString = InputBox("Please enter your month index number", _
"Selecting month index to generate your report")
If Len(InputString) = 0 Then Exit Sub ' no input
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets("InputData")
Dim slrg As Range: Set slrg = sws.Range("Q3:Q14")
Dim srrg As Range: Set srrg = sws.Range("P3:P14")
Dim srIndex As Variant
srIndex = Application.Match(CLng(InputString), slrg, 0)
If IsError(srIndex) Then Exit Sub ' month (number) not found
Dim sMonth As String: sMonth = srrg.Cells(srIndex)
Dim dws As Worksheet
For Each dws In wb.Worksheets
If InStr(1, dws.Name, sMonth, vbTextCompare) > 0 Then Exit For
Next dws
If dws Is Nothing Then Exit Sub ' worksheet not foundd
If Not wb Is ActiveWorkbook Then wb.Activate
dws.Select
End Sub
Look like you want to evaluate the formula in your code and read the output of that into a variable, then use that variable as the sheet name? If so then try the following:
Dim DestWS1 As Worksheet
Dim InputValue As Integer
InputValue = InputBox("Please enter your month index number", "Selecting month index to generate your report")
' Print the name of the airport to the Immediate Window(Ctrl + G)
Dim MonthIndexResult As String
' MonthIndexResult = _
' "=LOOKUP(" & InputValue & ",InputData!R3C17:R14C17,InputData!R3C16:R14C16)"
MonthIndexResult = Application.Evaluate("=LOOKUP(" & InputValue & ",InputData!R3C17:R14C17,InputData!R3C16:R14C16)")
Set DestWS1 = ThisWorkbook.Sheets(MonthIndexResult)
DestWS1.Select
You can find out more about this method here: Application.Evaluate method (Excel)
Related
Hi I have created macro where it opens the sheet based on user input,
what I need is once the new sheet is opened I have some fields where user need to fill those data(Different subjects marks) and calculate the percentage using formula then I need to fill those data to another sheet named "Data" without overwriting previous data?.
Please suggest how to add data without overwriting in vba.
Sub open_sheet()
Dim sourcesheet As Worksheet
Dim ClassA As Worksheet
Dim ClassB As Worksheet
Dim ClassC As Worksheet
Set sourcesheet = Sheets("Main")
Set ClassA = Sheets("Class A")
Set ClassB = Sheets("Class B")
Set ClassC = Sheets("Class C")
If sourcesheet.Range("Class").Value = "Class A" Then
Worksheets("Class A").Activate
ElseIf sourcesheet.Range("Class").Value = "Class B" Then
Worksheets("Class B").Activate
Else:
Worksheets("Class C").Activate
End If
End Sub
Copy Cell Values to Another Worksheet
Option Explicit
Sub CopyData()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets("Main")
' Reference the source range (the values from these cells will be copied).
Dim srg As Range: Set srg = sws.Range("A3,B4,C5")
' Retrieve the destination worksheet name.
' Hopefully you have created a drop down to easily select the class.
Dim dName As String: dName = sws.Range("Class").Value
' Late at night (tired), a final check could become a life saver:
Dim Msg As Long
Msg = MsgBox("This will copy to """ & dName & """." & vbLf & vbLf _
& "Are you sure?", vbQuestion + vbYesNo)
If Msg = vbNo Then Exit Sub
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Sheets(dName)
If dws.FilterMode Then dws.ShowAllData ' 'Find' will fail if 'dws' filtered
' Reference the first (available) destination cell.
Dim dCell As Range ' First Destination Cell
With dws.UsedRange
Dim dlCell As Range ' Last Cell
Set dlCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then Exit Sub ' empty worksheet
Set dCell = dws.Cells(dlCell.Row + 1, "A") ' below last in column 'A'
End With
' Copy the values from the source to the destination cells.
Dim sCell As Range
For Each sCell In srg.Cells
dCell.Value = sCell.Value
Set dCell = dCell.Offset(, 1) ' next, adjacent to the right
Next sCell
MsgBox "Data copied.", vbInformation
End Sub
In general, here's a way to append info to a table. I would just put your average calculations in the table total row.
Option Explicit
Sub FillNewRow1()
Dim Class_A As Worksheet
Dim ClassName As String
Dim DataRange
Dim lRow As Long
ClassName = Worksheets("Master").Range("B2").Value
Set Class_A = ThisWorkbook.Worksheets(ClassName)
DataRange = Worksheets("Master").Range("B5:B8")
lRow = Class_A.Range("A" & Rows.Count).End(xlUp).Row + 1
Class_A.Range("A" & lRow).Resize(1, UBound(DataRange, 1)).Value = _
Application.Transpose(DataRange)
End Sub
But seeing as we have no idea what your source od destination data look like that's the best help I can give.
Suplimentary :
PivotCharts & Pivot Tables are awesome:
I have a worksheet that contains approx 50 Named Ranges and I create a list of those named Ranges which contain data and hence need to be printed. The names of those containing data are stored in a column. I need to use these names as Print Areas in a macro to loop through and print each of these ranges on a separate page. My problem is how to select each Cell Value to use as the name of a Print Area. Any assistance would be greatly appreciated
Print Named Ranges From a List
Option Explicit
Sub PrintNamedRangesFromList()
' Define constants.
Const SRC_WORKSHEET_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "A2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source single-column range (containing the names).
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_WORKSHEET_NAME)
Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_CELL)
Dim slCell As Range
Set slCell = sws.Cells(sws.Rows.Count, sfCell.Column).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
' For each cell of the source range, print the range
' defined by its name contained in the cell.
' Account for not existing names and names not referring to a range.
' Log the process ('Debug.Print') in the Immediate window (Ctrl+G).
Dim sCell As Range, prg As Range, pName As Name, pString As String
For Each sCell In srg.Cells
pString = CStr(sCell.Value)
On Error Resume Next ' prevent error if name not found
Set pName = wb.Names(pString)
On Error GoTo 0
If Not pName Is Nothing Then ' name found
On Error Resume Next ' prevent error if name not a range
Set prg = pName.RefersToRange
On Error GoTo 0
If Not prg Is Nothing Then ' name is a range
prg.PrintOut
Debug.Print "The range """ & pName.Name & """ referring to """ _
& pName.RefersTo & """ was processed."
Set prg = Nothing ' reset for the next iteration
Else ' name is not a range
Debug.Print "The name """ & pName.Name & """ refers to """ _
& pName.RefersTo & """ and was not processed."
End If
Set pName = Nothing ' reset for the next iteration
Else ' name not found
Debug.Print "The name """ & pString & """ was not found."
End If
Next sCell
' Inform.
MsgBox "Named ranges printed.", vbInformation
End Sub
Select the Cells and run this macro. It will loop through all the values and print the named ranges.
Sub printSelectedNamedRanges()
Dim rng as Range
set rng = Selection.Range
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub
You can add this on top of previous code if You have named ranges in another named Range.
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
Range(namedRange).Select
So in you case the code will be
Sub printSelectedNamedRanges()
Dim rng as Range
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
set rng = Range(namedRange)
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub
I have the situation presented below in the image (Workbook 1):
and below (Workbook 2)
I want to copy my record from workbook 1 to workbook 2 if
in the Workbook 1 column A the string "surveyor" appears
the value from column B, which is exactly in the same row, where the string "suveyor" was found.
Then I would like to copy this value to my workbook 2.
I have prepared the code like this:
Sub FrontsheetAdd3()
Dim x As Worksheet, y As Worksheet, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
I have an error:
Method or data member not found
at the line
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
UPDATE:
After changing my code, which now looks like this:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Workbook, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
For i = 1 To 40
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor"
Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
At the line:
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
my active workbook (Workbook2), where the macro is meant to be is closing down and error Subscript out of range emerges.
What is missig then?
Please, try the next adapted code. It will copy from the csv file in the active one and exit loop:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Worksheet, ws As Worksheet, sPath As String, i As Long
sPath = ThisWorkbook.path & "\Survey_form.csv"
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
Set x = Workbooks.Open(sPath): Set ws = x.Sheets(1)
For i = 1 To 40
If ws.Range("A" & i).value = "surveyor" Then
y.Range("D34").value = ws.Rage("B" & i).value: Exit For
End If
Next i
End Sub
A VBA Lookup
Use Option Explicit which forces you to declare all variables.
Use variables (more of them) to make the code more readable.
Use meaningful variable names: sPath is a great name while x and y used for workbooks are terrible.
Instead of the loop, use Application.Match.
You can basically copy in three ways: Copy, Copy with PasteSpecial or Copy by Assignment (dCell.Value = sCell.Value) the latter being the most efficient when copying only values.
Option Explicit
Sub FrontsheetAdd3()
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets("Frontsheet")
Dim dCell As Range: Set dCell = dws.Range("D34")
Dim sPath As String: sPath = dwb.Path & "\Survey_form.csv"
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = wb.Worksheets("Survey_form")
' Determine the position of the first occurence of "surveyor" in column 'A'.
Dim sIndex As Variant
sIndex = Application.Match("surveyor", sws.Columns("A"), 0)
If IsNumeric(sIndex) Then ' "suveyor" was found
Dim sCell As Range: Set sCell = sws.Rows(sIndex).Columns("B")
dCell.Value = sCell.Value
Else ' "surveyor" was not found
dCell.Value = ""
End If
swb.Close SaveChanges:=False
'dwb.Save
End Sub
I have a task where I have two workbooks, one source and one destination. The task is to search a column in the destination workbook for a value that contains a certain string. When found, I have to search the source workbook in a certain column to find a matching string. I then take values from 2 other columns in that same row in the source workbook, combine them, and write them to a cell in the destination workbook.
The issue is that the values are being written to the wrong rows in the destination workbook, like this:
example1Broken
When it should look like this:
example2proper
Here is my current vba:
Sub CombineWorkbooks()
Dim var As Variant
Dim col As Variant
Dim i As Long
Dim Cell As Range
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(Filename:="CopyFromWorkbookSource.xlsx", UpdateLinks:=3)
Dim wbDest As Workbook
Set wbDest = Workbooks.Open(Filename:="CopyFromWorkbookDest.xlsm", UpdateLinks:=3)
Dim address As Variant
Dim newAddressRow As Variant
Dim sourceVal1 As Variant
Dim sourceVal2 As Variant
'Dest wb number column that contains the search query
Dim sourceCol As Integer
sourceCol = 1
wbDest.Activate
'col = Split(ActiveCell(1).address(1, 0), "$")(0)
For i = 1 To Rows.Count
var = Cells(i, sourceCol).Value
If var Like "*WI*" And Not IsEmpty(Cells(i, sourceCol).Value) Then
wbSource.Activate
Set Cell = Nothing
Set Cell = Selection.Find(What:=var, LookIn:=xlValues)
If Cell Is Nothing Then
' MsgBox "Nothing"
Else
'We found a match!
MsgBox "Found hit for " & var & ": " & Cell.address
'This is where the value was found in the source workbook
address = Cell.address
'This is where the new value must go in the dest workbook NOTE the column letter must change!
newAddressRow = Split(address, "$A$")(1)
'Get the cell values from the source wb
sourceVal1 = Cells(newAddressRow, 2)
sourceVal2 = Cells(newAddressRow, 3)
MsgBox "SourceVal1: " & sourceVal1 & " SourceVal2: " & sourceVal2 & " Newaddressrow: " & newAddressRow & " i: " & i
'Activate the dest workbook for pasting
wbDest.Activate
'Write the source wb values into a single cell in the dest wb
Cells(i, 2).Value = sourceVal1 & Chr(10) & sourceVal2
End If
End If
Next i
End Sub
Consider removing the address variable and set the sourceVals using the found Cell's Row parameter. Also consider direct referencing workbooks and sheets instead of activating; see below.
Sub CombineWorkbooks()
Dim i As Long
Dim Cell As Range
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim sourceCol As Integer 'Destwb number column that contains the search query
Set wbSource = Workbooks.Open(Filename:="CopyFromWorkbookSource.xlsx", UpdateLinks:=3)
Set wbDest = Workbooks.Open(Filename:="CopyFromWorkbookDest.xlsm", UpdateLinks:=3)
sourceCol = 1
' start at 2 to dodge the header
For i = 2 To wbDest.Sheets(1).Rows.Count
'this conditional can be removed if all non-header rows will contain WI
If wbDest.Sheets(1).Cells(i, sourceCol).Value Like "*WI*" Then
Set Cell = wbSource.Sheets(1).UsedRange.Find(What:=wbDest.Sheets(1).Cells(i, sourceCol).Value, LookIn:=xlValues)
If Not Cell Is Nothing Then
'We found a match!
'Write the source wb values into a single cell in the dest wb
Cells(i, 2).Value = wbSource.Sheets(1).Cells(Cell.Row, 2) & Chr(10) & wbSource.Sheets(1).Cells(Cell.Row, 3)
End If
End If
Next i
End Sub
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim lookup As String
Dim X As Range
Dim y As Range
Dim a, b As Variant
Set sourcewb = ActiveWorkbook
Set X = sourcewb.Worksheets(1).Range("A:G")
Dim sourceSheet As Worksheet
Set sourceSheet = sourcewb.Worksheets(1)
MsgBox sourceSheet.Name
X.Select
MsgBox sourcewb.Name
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Application.Workbooks.Open(Filename)
Set y = targetWorkbook.Worksheets(1).Range("A:G")
y.Select
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
MsgBox targetSheet.Name & " This is the country code sheet name "
Set targetWorkbook = ActiveWorkbook
MsgBox targetWorkbook.Name
y.Select
sourcewb.Activate
MsgBox ActiveWorkbook.Name & " IS the active workbook"
MsgBox sourcewb.Name
MsgBox sourcewb.Name & " This is the source workbook "
MsgBox targetWorkbook.Name & " This is the target workbook "
MsgBox "Trying to map from target to source "
With sourcewb.Worksheets(1)
For rw= 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(rw, 4) = Application.VLookup(Cells(rw, 1).Value, y, 4, False)
'MsgBox Cells(a, 4).Value2
Next rw
End With
MsgBox "All required columns from source mapped to target file "
Set sourcewb = ActiveWorkbook
MsgBox ActiveWorkbook.Name
Application.ScreenUpdating = False
I have a workbook sourcewb. I open another workbook targetworkbook from the sourceworkbook. My Columns in sourcewb are Sl No, Country code,country names
slno country code country name Region
1 AL Algeria
2 US USA
3 UK United Kingdom
My targetwb is
country code country name Region
AL Algeria EMEA
US USA Americas
UK United Kingdom Europe
I am trying to fetch Region column from country code in the sourcewb as there is no slno in the targetwb and the order of country codes are not the same as sourcewb.
I get an error 2042. I have tried storing the target value with string, int, long, variant, nothing has worked till now.
Any suggestions or help would be really helpful.
With some "clean-up" and organization to your original code, try the code below.
3 comments:
When you are using a With statement, don't forget to nest all objects inside with a ..
Stay away from using Select and Activate, not only it's not necessary, it also slows down your code's run-time.
You need to trap the scenario that Application.VLookup will not find a value, and then you will get a run-time error.
Explanations inside the code as comments.
Code
Option Explicit
Sub AutoVLookup()
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim X As Range
Dim y As Range
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim lookup As String
Dim a, b As Variant
Set sourcewb = ActiveWorkbook ' set Activeworkbook object
Set sourceSheet = sourcewb.Worksheets(1) ' set source sheet
Set X = sourceSheet.Range("A:G") ' set source range
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Workbooks.Open(Filename) ' set target workbook object
Set targetSheet = targetWorkbook.Worksheets(1) ' set target sheet
Set y = targetSheet.Range("A:G") ' set target range
With sourceSheet
For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in column A
' make sure VLoookup found a match, otherwise you will get a run-time error
If Not IsError(Application.VLookup(.Cells(rw, 1).Value, y, 4, False)) Then
.Cells(rw, 4) = Application.VLookup(.Cells(rw, 1).Value, y, 4, False) ' this will fetch column "E" values
'MsgBox Cells(a, 4).Value2
End If
Next rw
End With
MsgBox "All required columns from source mapped to target file "
Application.ScreenUpdating = True
End Sub