I'm trying to write a macro that loops through all the Workbooks in a folder, and for each one sends an email with a range of rows that meet criteria. When I run the macro, it does this for the first file but stops at the second giving the error "Method 'Union' of object '_Global' failed", pointing to the line "Set rng2 = Union(rng2, row)". Below is the relevant code:
Sub LoopThroughFiles()
Dim File As String
File = Dir("FilePath\")
While (File <> "")
Set WorkBk = Workbooks.Open("FilePath\" & File)
Dim rng As Range
Dim row As Range
Dim rng2 As Range
Dim strbody As String
Dim OutApp As Object
Dim OutMail As Object
Set rng = Range("B52:I200")
For Each row In rng.Rows
If row.Columns(7) >= Date Then
If Not rng2 Is Nothing Then
'Below is the line that gets the error
Set rng2 = Union(rng2, row)
Else
Set rng2 = row
End If
End If
Next
'Email code removed
WorkBk.Close savechanges:=True
File = Dir()
Wend
End Sub
Any help would be greatly appreciated!
You're attempting to Union with the same range that you built using the previous Workbook. You need to clear the rng2 for each file you process:
WorkBk.Close savechanges:=True
Set rng2 = Nothing '<---You just closed the workbook this range was built with.
File = Dir()
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 have the below code placed on my active workbook which copy's data from a closed workbook. It works fine and very fast but i can only copy up to 8 columns if I select more than that I get a
run-time error 6 - Overflow
Code:
Sub Get_Data()
Dim RngToCopy As Range
Dim wkbk As Workbook
Dim DestCell As Range
Dim myFileNames As Variant
Dim iCtr As Long
Dim testStr As String
Set DestCell = ThisWorkbook.Worksheets(1).Range("a1")
myFileNames = Array("C:\my documents\excel\book1.xlsm") ' i could add more workbooks to copy from and append on current worksheet
For iCtr = LBound(myFileNames) To UBound(myFileNames)
testStr = ""
On Error Resume Next
testStr = Dir(myFileNames(iCtr))
On Error GoTo 0
If testStr = "" Then
MsgBox myFileNames(iCtr) & " doesn't exist!"
Else
Set wkbk = Workbooks.Open(Filename:=myFileNames(iCtr))
With wkbk.Worksheets(1)
Set RngToCopy = .Range("a2:r2", _
.Cells(.Rows.Count, "A").End(xlUp))
End With
DestCell.Resize(RngToCopy.Rows.Count, _
RngToCopy.Columns.Count).Value _
= RngToCopy.Value
Set DestCell = DestCell.Offset(RngToCopy.Rows.Count, 0)
wkbk.Close savechanges:=False
End If
Next iCtr
End Sub
when I debug the line that it goes to is: where am I going wrong :(
DestCell.Resize(RngToCopy.Rows.Count, _
RngToCopy.Columns.Count).Value _
= RngToCopy.Value
the source workbook is a big file with a lot of data, I tried most of the suggestions when I researched on the error but no luck.
if it helps workbook contains 18 columns and 300k+ rows
Try a different approach, use Copy >> PasteSpecial (values only) :
' 1st: set copy range
With wkbk.Worksheets(1)
Set RngToCopy = .Range("A2:R2", .Cells(.Rows.Count, "A").End(xlUp))
End With
' 2nd: set destination range start position
Set DestCell = DestCell.Offset(RngToCopy.Rows.Count, 0)
' 3rd: use copy>>paste special (values only)
RngToCopy.Copy
DestCell.PasteSpecial xlPasteValues
I am actually quite new to VBA but I am doing some coding to streamline my office work. I understand this would be some amateur level questions to most of you but I tried to google for quite a while and I do not find satisfactory answer.
I have an excel write up that based on the inputted parameters, It should ultimately refer to the correct sheet -> copy the selected cells -> Generate an e-Mail with the body pasting the copied cells along with an attachment
I can do most of the parts, just that I cannot reference the "Correct Sheet" as a variable in my codes. Please shed some lights on for me. Thank you.
Here are most of the codes, the rest are irrelevant and too clumsy to paste all I guess.
Sub GenerateEmail()
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim StrAtt1 As String
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
On Error Resume Next
With olMailItm
SDest = ""
StrAtt1 = ThisWorkbook.Path & "\PDF\" & Sheets("Email_Generator").Range("B16")
.To = Worksheets("Email_Generator").Range("B14")
.CC = "Myself"
.BCC = ""
.Subject = Worksheets("Email_Generator").Range("B18")
.HTMLBody = RangetoHTML(rng)
.attachments.Add StrAtt1
.Display
End With
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
Specifically, I would like this code "Sheets("test") as a Cell in Sheet "Test" that is a variable based on the paramters I have inputted in my excel so that this code will reference to the correct worksheet
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
But when I identify the sheet as a named sheet e.g. Sheets("Email1"), it perfectly works, just that it cannot become a variable.
I hope this post is not too long to read because I tried to be as specific as possible. Thank you to all who reads this and tries to help. I really appreciate it.
This function to return the worksheet name selected by the user from an InputBox. If the user cancels or enters an invalid number then the function returns a zero length string.
Sub TestFunction()
Dim SheetName As String
Dim rng As Range
SheetName = getSheetNameFromInputBox
If Len(SheetName) = 0 Then
MsgBox Prompt:="Try Again", Title:="Invalid Sheet"
Exit Sub
End If
Set rng = Sheets(SheetName).Range("A1:Q500").SpecialCells(xlCellTypeVisible)
MsgBox rng.Address(External:=True)
End Sub
Function getSheetNameFromInputBox() As String
Dim ws As Worksheet
Dim Prompt As String
Dim result
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet3" Then
Prompt = Prompt & ws.Index & ") " & ws.Name & vbCrLf
End If
Next
result = InputBox(Prompt:=Prompt, Title:="Enter the Worksheet number", Default:=1)
On Error Resume Next
If IsNumeric(result) Then getSheetNameFromInputBox = Worksheets(CInt(result)).Name
On Error GoTo 0
End Function
I was attempting to extract data from other workbooks into a master workbook. All of these workbooks were saved in one folder. And I wanted to open other workbooks automatically not manually. The data that I need to extract are non adjacent cells, and I want the data extracted from each source workbook to be shown in rows in the master workbook (because I have a head line in row 1, so after extracting data from the first workbook and paste in row 2, the data extracted from the second workbook will be listed in row 3 and so on)
However, when I ran the macro I got stuck in Transpose.
Below is my code
Sub LoopThroughDirectory()
Dim MyFile As String
Dim wkbSource As Workbook
Dim wkbTarget As Workbook
Dim erow As Single
Dim Filepath As String
Dim copyRange As Range
Dim cel As Range
Dim pasteRange As Range
Filepath = "C:\xxxxx\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Import Info.xlsm" Then GoTo NextFile
Set wkbTarget = Workbooks("Import Info.xlsm")
Set wkbSource = Workbooks.Open(Filepath & MyFile)
Set copyRange = wkbSource.Sheets("sheet1").Range("c3,f6,f9,f12,f15,f19,f21,f27,f30,f33,f37,f41")
Set pasteRange = wkbTarget.Sheets("sheet1").Range("a1")
For Each cel In copyRange
cel.Copy
ecolumn = wkbTarget.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
wkbTarget.Worksheets("Sheet1").Paste Destination:=wkbTarget.Worksheets("Sheet1").Range(Cells(1, ecolumn).Address)
pasteRange.Cells(1, ecolumn).PasteSpecial xlPasteValues
Next
Application.CutCopyMode = False
wkbSource.Close
NextFile:
MyFile = Dir
Loop
End Sub
What I have done so far:
I transposed the data I extracted from source workbooks but they were not shown in the master workbook as what I expected. All of them are in row 1
I don't have much experience in VBA and I feel like the code I wrote to copy non adjacent cells and transpose in the master workbook makes the loop much more complicated. But I don't know where I went wrong or how to fix that.
Please help me. Thank you so much!
You have to set the destination range outside of the loop and offset it inside of the loops:
Sub LoopThroughDirectory()
Dim Filepath As String, MyFile As String
Dim wkbSource As Workbook, wkbTarget As Workbook
Dim copyRange As Range, cel As Range, pasteRange As Range
Set wkbTarget = Workbooks("Import Info.xlsm")
Set pasteRange = wkbTarget.Sheets("sheet1").Range("a2") ' start at row 2
Filepath = "C:\xxxxx\"
MyFile = Dir(Filepath)
While MyFile > ""
If MyFile = "Import Info.xlsm" Then GoTo NextFile
Set wkbSource = Workbooks.Open(Filepath & MyFile)
Set copyRange = wkbSource.Sheets("sheet1").Range("c3,f6,f9,f12,f15,f19,f21,f27,f30,f33,f37,f41")
For Each cel In copyRange
pasteRange.Value = cel.Value ' "copy" the value
Set pasteRange = pasteRange.Offset(, 1) ' move to the next column
Next
wkbSource.Close
Set pasteRange = pasteRange.EntireRow.Resize(1,1) ' move back to the first cell in the row
Set pasteRange = pasteRange.Offset(1) ' move to the cell bellow (next row)
NextFile:
MyFile = Dir
Wend
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