i have been assigned to use the .match function in vba, to compare 2 different columns in 2 different workbooks.
here is my code so far.. how do i use the match function to my goal ?
Sub Ob_match()
Dim swb As Workbook, dwb As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim oCell As Range, oMatch As Range
Set swb = ActiveWorkbook
Set sws = swb.Sheets("Item")
Set dwb = Workbooks.Open(swb.Path & "\EPC_EndItem.xlsm", ReadOnly:=True)
Set dws = dwb.Sheets("Data")
If Not oMatch Is Nothing Then
oCell.Offset(0, 1) = "Y"
Else
oCell.Offset(0, 1) = ""
End If
Next oCell
MsgBox "Processing completed"
End Sub
To run this code you should be on your your first workbook and second work-book should be open in background, I find this as an easier method than to call workbook using it's address, you may change that if you like
Sub vl()
Dim lastrow As Long
Sheets("Items").Select
lastrow = Range("B" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Formula = "=IF(VLOOKUP(RC2,[Book2]Data!C4,1,FALSE), ""OK"","""")"
End Sub
Here I assumed that Name of your second book is Book2.
Change it to whatever it is in the code.
Hope this helps :)
Related
I am using VBA to try to see if values in cells from one workbook match the named ranges from another workbook and if they do match then copy paste values from another column in those named ranges. I know they will match. the purpose is just to copy the values over into their designated named range.
The problem is in this line:
If rng = ws2.Range("NamedRange") Then
Here is my code below:
Sub Button4_Click()
Dim strFileName As String
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim wb2 As Workbook
Dim ws2 As Worksheet
Dim cell As Range
Dim rng As Range
Dim RangeName As String
Dim CellName As String
''Set wb2 = ActiveWorkbook
''Set ws2 = wb2.Sheet("Output")
''ws2.Range("D1:D12").Copy
''Set wb1 = ActiveWorkbook
strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "\BAC GVP - Template_Update_121917.xlsm"
If Dir(strFileName) <> vbNullString Then
Set wb1 = Workbooks.Open(strFileName)
Else
MsgBox "Sorry, the file does not exist on your Desktop at this time, please drop a copy to your Desktop from server!"
End If
''Set wb2 = ThisWorkbook
''Set ws2 = wb2.Sheets("Output")
''Set ws1 = wb1.Sheets("RVP Local GAAP")
''ws2.Range("D4:D12").Copy
''ws1.Range("G13:G21").PasteSpecial xlPasteValues
''RangeName = "myData"
''CellName = "G11:G83"
''Set cell = Worksheets("RVP Local GAAP").Range(CellName)
''ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
''RangeName = "NamedRange"
''CellName = "C4:C12"
Set wb2 = ThisWorkbook
Set ws2 = wb2.Sheets("Output")
Set ws1 = wb1.Sheets("RVP Local GAAP")
For Each rng In ws1.Range("CurrentTaxPerLocalGAAPProvision")
If rng = ws2.Range("NamedRange") Then
ws2.Range("ReportBalance").Copy
ws1.Range("CurrentTaxPerLocalGAAPProvision").PasteSpecial xlPasteValues
MsgBox "Values Copied Successfully"
End If
Next rng
MsgBox "Both Ranges do not have the same data"
End Sub
See image below - Cell G29 is called "GVP_Donations_CurrentTaxPerLocalGAAPProvision"... so for this example I would want $4,313 to appear in the cell G29
CurrentTaxPerLocalGAAPProvision:
Range ("NameRange"):
Your line saying
If rng = ws2.Range("NamedRange") Then
is crashing out due to the attempt to compare the value of rng (e.g. "" when rng is referring to the cell G29) with an array of values (the values in "NamedRange"). VBA cannot handle the comparison of a scalar to a vector. But it isn't what you are wanting to do anyway.
I believe that, to do what it seems you are trying to do, you can replace your loop with:
'Loop through all the values in NamedRange
For Each rng In ws2.Range("NamedRange")
'Transfer the value from the next column to the appropriate range in the
'destination sheet
ws1.Range(rng.Value).Value = rng.Offset(0, 1).Value
Next
MsgBox "Values Copied Successfully"
If only some of the values in "NamedRange" should be copied, then you may need to include a bit of testing to see whether the ranges are in the correct target area:
Dim dstRng As Range
'Loop through all the values in NamedRange
For Each rng In ws2.Range("NamedRange")
Set dstRng = Nothing
On Error Resume Next
Set dstRng = ws1.Range(rng.Value)
On Error GoTo 0
'Check that the range exists in destination sheet
If Not dstRng Is Nothing Then
'Check that the range exists in the appropriate area
If Not Intersect(dstRng, ws1.Range("CurrentTaxPerLocalGAAPProvision")) Is Nothing Then
'Transfer the value from the next column to the appropriate range in the
'destination sheet
dstRng.Value = rng.Offset(0, 1).Value
End If
End If
Next
MsgBox "Values Copied Successfully"
I've been trying to come up with a way to split a workbook into separate workbooks based on identified worksheets in the workbook.
For example:
Say I had a worksheet for every letter in the alphabet.
I would want to split worksheets A through C into a new workbook named "A through C."
D through I will go into a new workbook named "D through I."
etc...
My idea would be to first insert a worksheet that in column A names the new workbook it will become and Columns b through as many columns as there are will the names of the worksheets to be copied into the new workbook.
Does anyone have an idea of how to make a macro for this? I've tried myself but have been unsuccessful.
Thank you!
I found this Macro out there. Does anyone think it can be modified to work?
Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim WB As Workbook
Application.ScreenUpdating = False
Set Sh = Worksheets("Sheet1")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set WB = Workbooks.Add
Rng.AutoFilter Field:=1, Criteria1:=Item
Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
Rng.AutoFilter
With WB
.SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
.Close
End With
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub
The following code assumes you have your control sheet (named "Split Parameters") in the workbook containing the macro, and it is set out with the desired filenames in column A, and the sheets that you wish to copy into that file (from the ActiveWorkbook, which might, or might not, be the one containing the macro) listed in columns B, C, etc. Row 1 is assumed to be headings, and is therefore ignored.
Sub SplitBook()
Dim lastRow As Long
Dim LastColumn As Long
Dim srcWB As Workbook
Dim newWB As Workbook
Dim i As Long
Dim c As Long
Dim XPath As String
Dim newName As String
Dim sheetName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set srcWB = ActiveWorkbook
XPath = srcWB.Path
With ThisWorkbook.Worksheets("Split Parameters")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
'Take the first worksheet and create a new workbook
sheetName = .Cells(i, "B").Value
srcWB.Sheets(sheetName).Copy
Set newWB = ActiveWorkbook
'Now process all the other sheets that need to go into this workbook
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
For c = 3 To LastColumn
sheetName = .Cells(i, c).Value
srcWB.Sheets(sheetname).Copy After:=newWB.Sheets(newWb.Sheets.Count)
Next
'Save the new workbook
newName = .Cells(i, "A").Value
newWB.SaveAs Filename:=xPath & "\" & newName & ".xls", FileFormat:=xlExcel8
newWB.Close False
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I am attempting to write a macro in a workbook whose purpose is to display the key information from each of a set of excel files. the first column contains the name of the file which will be used in the code.
the code I have written so far should loop through the list of 11 file names in the summary sheet and pull the info called from cell E21 in each of those files and place it in cell Hx in the summary sheet.
I have had no luck getting it to work so far, my first error im getting is "invalid Qualifier" on the line that says "MySheet". I know that there are alot of other mistakes here as I have never attempted to write a sub that pulls from other closed workbooks.
My code is as follows:
Option Explicit
Sub OEEsummmary()
Dim Gcell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
MySheet = ActiveSheet.Name
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Txt
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With ThisWorkbook.ActiveSheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
Ive looked at what an invalid qualifier error is and i dont understand what i have wrong with that part of my code. Any help with this and any other blinding errors would be greatly appreciated!
The issue I see that's causing the Invalid Qualifier error is that you are declaring MySheet as a string, but trying to use it as a Worksheet object. Below I've declared it as a worksheet and set it to the Activesheet. I also changed the ThisWorkbook.ActiveSheet reference to MySheet, which I think is what you want. Also changed Txt to Text:
Sub OEEsummmary()
Dim Gcell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Text
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With MySheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
I have the following code which I am trying to get to name the entire A and B columns range according to the worksheet tab name. I want each A:B range of cells in each worksheet to be named RoomCode_ + the name of the excel sheet tab.
So for example if I had 3 sheets called XYZ, ABC and DEF, then my cell range names for those 3 sheets respectively should be:
RoomCode_XYZ
RoomCode_ABC
RoomCode_DEF
I would typically do this manually by highlighting the cell range and just typing the range name I wanted, however I have over 150 tabs and would like to be able to do them all automatically through this process.
Sub nameRanges()
Set wbook = ActiveWorkbook
For Each sht In wbook.Worksheets
sht.Activate
RangeName = "RoomCode_" + ActiveSheet.Name
CellName = "A:B"
Set cell = ActiveWorksheets.Range(CellName)
ActiveWorksheets.Names.Add Name:=RangeName, RefersTo:=cell
Next sht
End Sub
Just a bit of refactoring to get what you need. Biggest this to work directly with objects and eliminate the Active... stuff.
Also ActiveWorksheets is not proper syntax in any way.
Sub nameRanges()
Dim wbook As Workbook
Set wbook = ThisWorkbook
Dim sht As Worksheet
For Each sht In wbook.Worksheets
Dim RangeName As String, CellName As String
RangeName = "RoomCode_" + sht.Name
CellName = "A:B"
Dim cell As Range
Set cell = sht.Range(CellName)
sht.Names.Add Name:=RangeName, RefersTo:=cell
Next sht
End Sub
Here's another way:
Option Explicit
Sub nameRanges()
Dim sht As Worksheet
Dim RangeName As String
Dim cell As String
For Each sht In ActiveWorkbook.Worksheets
RangeName = "RoomCode_" + sht.Name
cell = "=" & sht.Name & "!" & "A:B"
Names.Add Name:=RangeName, RefersTo:=cell
Next sht
End Sub
I think that you would want to add the names to the workbook names collection. The way it is now you'll still have to reference the individual worksheet before you can access the name.
WorkSheets("RoomCode").Range("RoomCode_XYZ")
By adding the names to the workbook you'll be able to access no matter the ActiveSheet.
Range("RoomCode_XYZ")
Sub nameRanges()
Dim wbook As Workbook
Set wbook = ThisWorkbook
Dim sht As Worksheet
For Each sht In wbook.Worksheets
Dim RangeName As String, CellName As String
RangeName = "RoomCode_" + sht.Name
CellName = "A:B"
Dim cell As Range
Set cell = sht.Range(CellName)
ThisWorkBook.Names.Add Name:=RangeName, RefersTo:=cell
Next sht
End Sub
The problem: I am trying to copy data from one workbook to another.
Lets say I have a workbook (called DATA) with several worksheets filled with data. Each column of data has a unique heading (all headings on the same row).
On the other hand I have another workbook (called REPORT) with one worksheet that contains only the heading of the data (in one row). They are not in the same order as in DATA workbook. For example I have 3 headings in REPORT worksheet that can be found in different worksheets in DATA workbook.
I need to loop through all the worksheets in the DATA workbook and copy paste the whole column to the REPORT worksheet when the same heading is found.
This image may help to understand. Explanation
My first attempt:
Dim MyFile As String
Dim ws As Worksheet
''Workbook that contains one worksheet with all the headings ONLY NO DATA
Dim TargetWS As Worksheet
Set TargetWS = ActiveSheet
Dim TargetHeader As Range
''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")
''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Dim SourceWB As Workbook
Set SourceWB = Workbooks("Source.xlsx")
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range
''Stores the col of the found value and the last row of data in that col
Dim RealLastRow As Long
Dim SourceCol As Integer
''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
ws.Activate
For Each Cell In TargetHeader
If Cell.Value <> "" Then
Set SourceCell = Rows(SourceHeaderRow).Find _
(Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
SourceCol = SourceCell.Column
RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If RealLastRow > SourceHeaderRow Then
Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
SourceCol)).Copy
TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
End If
End If
End If
Next
Next
I am getting an error of Application-defined or object-defined error Run-time 1004. Is there something wrong with my logic/syntax..?
Please help I am so bad in VBA.
Thanks in advance!
your last edited code works
but you're making unnecessary checks and I'd suggest you to loop through each sheet header and check if it exists in TargetHeader range to possibly subsequently copy its column to SourceWB
furthermore you may want to have your code more robust and check for actual wanted workbooks/worksheets existence before attempting to set variables to them
like follows:
Option Explicit
Sub main()
Dim SourceWB As Workbook
Dim ws As Worksheet, TargetWS As Worksheet
Dim TargetHeader As Range, cell As Range, SourceCell As Range
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Set SourceWB = GetWb("Source.xlsx")
If SourceWB Is Nothing Then Exit Sub
''Workbook that contains one worksheet with all the headings ONLY NO DATA
'Set TargetWS = ActiveSheet
Set TargetWS = GetWs("REPORT") 'it will get the first worksheet (if any) in "REPORT" workbook (if open)
If TargetWS Is Nothing Then Exit Sub
''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")
''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
For Each cell In ws.Rows(SourceHeaderRow).SpecialCells(xlCellTypeConstants, xlTextValues)
Set SourceCell = TargetHeader.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
Range(cell.Offset(1), ws.Cells(ws.Rows.Count, cell.Column).End(xlUp)).Copy
SourceCell.Offset(1).PasteSpecial xlPasteValues
End If
Next
Next
End Sub
Function GetWb(wbName As String) As Workbook
On Error Resume Next
Set GetWb = Workbooks(wbName)
On Error GoTo 0
If GetWb Is Nothing Then MsgBox "Sorry, the workbook '" & wbName & "' isn't open" & vbCrLf & vbCrLf & "Please open it and run the macro again"
End Function
Function GetWs(wbName As String, Optional wsName As Variant) As Worksheet
Dim wb As Workbook
Dim ws As Worksheet
Set wb = GetWb(wbName)
If wb Is Nothing Then Exit Function
On Error Resume Next
If IsMissing(wsName) Then
Set GetWs = wb.Worksheets(1) ' if no ws name passed then get the first one
Else
Set GetWs = wb.Worksheets(wsName)
End If
On Error GoTo 0
If GetWs Is Nothing Then MsgBox "Sorry, the worksheet '" & wsName & "0 isn't in '" & wb.Name & "'" & vbCrLf & vbCrLf & "Please open a valid workbook and run the macro again"
End Function