What I am trying to do is:
create new Sheet in my Active Workbook (wsData)
Open workbook with Filename (wbimport)
Autofilter for Array (arrCriteriaPH1())
Copy filtered Cells from wbimport into wsData in my initial Workbook.
My Problem:
The code works only sometimes, even though I don't change anything. Sometimes both worksheets get generated, sometimes only one and I get the error of paste special method of Range Class failed. Import data is always the same.
I tried to reduce the code as much as possible. Hopefully someone is able to help!
Error appears almost at the end of the loop:
wsData.Cells.ClearContents
wbImport.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeVisible).Copy
wsData.Range("J1").PasteSpecial Paste:=xlPasteValues
For Each i In Dates()
Dim App As New Excel.Application 'create a new (hidden) Excel
'create new sheet for new data'
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = i
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Sheets(i)
wsData.Cells.ClearContents
' open the import workbook in new Excel (as read only)
Dim wbImport As Workbook
Dim FileN As String
FileN = "\\10.64.1.151\Load And Cover\Load And Cover_Ops Internal\Load_and_Cover_" & Format(i, "YYYY-MM-DD") & ".xlsb"
Set wbImport = App.Workbooks.Open(Filename:=FileN, UpdateLinks:=True, ReadOnly:=True)
'wbImport.Worksheets("Data").Activate'
'Array for Autofilter criteria'
Dim lngCriteriaCountPH1 As Long
Dim arrCriteriaPH1() As String
lngCriteriaCountPH1 = 6
ReDim arrCriteriaPH1(0 To lngCriteriaCountPH1 - 1)
arrCriteriaPH1(0) = "Commercial All-In-One"
arrCriteriaPH1(1) = "Commercial Desktop"
arrCriteriaPH1(2) = "Commercial Notebook"
arrCriteriaPH1(3) = "Commercial Tablet"
arrCriteriaPH1(4) = "Visuals"
arrCriteriaPH1(5) = "Workstation"
'Autofilter aktivieren'
Dim LastRowColumnA As Long
LastRowColumnA = wbImport.Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long
LastCol = wbImport.Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
colletter = Split(Cells(1, LastCol).Address, "$")(1)
Set rngFilterRange = wbImport.Worksheets("Data").Range("A1:" & colletter & LastRowColumnA)
rngFilterRange.AutoFilter
rngFilterRange.AutoFilter Field:=2, Criteria1:="GAT", Operator:=xlFilterValues
rngFilterRange.AutoFilter Field:=7, Criteria1:=arrCriteriaPH1(), Operator:=xlFilterValues
rngFilterRange.AutoFilter Field:=19, Criteria1:="Y", Operator:=xlFilterValues
'copy the data of the import sheet
wsData.Cells.ClearContents
wbImport.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeVisible).Copy
wsData.Range("J1").PasteSpecial Paste:=xlPasteValues
App.CutCopyMode = False 'clear clipboard (prevents asking when wb is closed)
wbImport.Close SaveChanges:=False 'close wb without saving
App.Quit 'quit the hidden Excel
Next i
Related
I am new to macro.
I have written macro code to add the rows based on filter from the macro enabled excel file and copy the results in new excel file.
I have VBS to run the macro.
My problem is
when I run the macro from the xlsm file ,it is running only once and the values are stored correctly by creating the xlsx file
But when I run the same macro from VBS, macro is running multiple times with error msg which is posted below
My Macro is :
Sub SuppOSCalculation()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim Total As Double
Dim AddRange As Range
Dim c As Variant
Dim list As Object, item As Variant
Dim i As Integer
spath = "Mypath\"
sFile = spath & "supp.xlsm"
Set wb = Workbooks.Open(sFile)
SendKeys "{Enter}"
Set src = wb.Sheets("supp")
Set tgt = wb.Sheets("Sheet3")
Set list = CreateObject("System.Collections.ArrayList")
i = 2
' turn off any autofilters that are already set
src.AutoFilterMode = False
' Copy all fileds to second sheet and remove duplicates
src.Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy tgt.Range("A2")
tgt.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
' Add all values in Second sheet to a list
With tgt
For Each item In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If Not list.Contains(item.Value) Then list.Add item.Value
Next
End With
tgt.Range("A1").Value = "Supplier GL Code"
tgt.Range("B1").Value = "Supplier OS Report-Invoice Amount"
' find the last row and Column with data in column A
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox lastCol
' the range that we are auto-filtering (all columns)
Set filterRange = src.Range("A2:AF2" & lastRow)
For Each item In list
'From List set the value for the filter
' MsgBox (item)
filterRange.Range("C2").AutoFilter field:=3, Criteria1:=item
'Add the column value after applying filter
Set AddRange = src.Range("P3:P" & src.Range("P" & Rows.Count).End(xlUp).Row)
Total = WorksheetFunction.Sum(AddRange.SpecialCells(xlCellTypeVisible))
'MsgBox (Total)
tgt.Range("B" & i).Value = Total
i = i + 1
Next
'src.AutoFilterMode = False
'wb.Close SaveChanges:=True
Dim lRow, lCol As Integer
tgt.Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For Each cell In Range(Cells(1, "B"), Cells(1, lCol))
Union(Range("A2:A" & lRow), Range(Cells(2, cell.Column), Cells(lRow, cell.Column))).Copy
Workbooks.Add
Range("A1").PasteSpecial
ActiveWorkbook.SaveAs Filename:= _
"SupOSTBCalc\" & cell.Value & ".xlsx" 'You might want to change the extension (.xls) according to your excel version
Next cell
ActiveWorkbook.Close
Application.CutCopyMode = False
'wb.Close
' Application.DisplayAlerts = False
' Application.AlertBeforeOverwriting = False
' Application.ScreenUpdating = False
' SendKeys "{Enter}"
wb.Close savechanges:=False
End Sub
VBS is:
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("Mypath\SupOSTBCalc.xlsm")
xlApp.Run "Module1.SuppOSCalculation"
'xlBook.Save
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Error msg is
Pls help me to solve this.
I have a code which will read file data from the defined path and copies the data to my Macro workbook's sheet. When I am running the code line by line, it is working perfectly fine. But when I run the entire code, it is getting closed automatically without my permission. Below is my previous code.
Set thisWB = ThisWorkbook
'Open File and Copy Data
Set thatWB1 = Workbooks.Open(TimFilePath)
TFPLR = Cells(Rows.Count, "A").End(xlUp).Row
TFPLC = Cells(1, Columns.Count).End(xlToLeft).Column
TFPLCLTR = Split(Cells(1, TFPLC).Address(True, False), "$")(0)
'MsgBox TFPLCLTR
Range("A2:" & TFPLCLTR & TFPLR).Select
Selection.Copy
'Paste Selected Data in Time Ranges Sheet
'thisWB.Activate
thisWB.Sheets(TimSheet).Activate
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Close the File
thatWB1.Close SaveChanges:=False
After I made the below updates, the workbook is still closing.
Set thisWB = ThisWorkbook
'Open Time Range File and Copy Data
Set thatWB1 = Workbooks.Open(TimFilePath)
TFPLR = Cells(Rows.Count, "A").End(xlUp).Row
TFPLC = Cells(1, Columns.Count).End(xlToLeft).Column
TFPLCLTR = Split(Cells(1, TFPLC).Address(True, False), "$")(0)
'MsgBox TFPLCLTR
Range("A2:" & TFPLCLTR & TFPLR).Copy
'Selection.Copy
'Paste Selected Data in Time Ranges Sheet
thisWB.Sheets(TimSheet).Activate
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
thisWB.Sheets(TimSheet).Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Close the Time ranges File
thatWB1.Close SaveChanges:=False
Best way to solve this is by declaring a variable to fully control the open workbook in the same way you have for thisWB, eg:
Dim thatWB As Workbook
Set thatWB = Workbooks.Open(TimFilePath)
'do the work
thatWB.Close SaveChanges:=False
This code should work without relying on Active anything.
Option Explicit 'This line is REALLY important.
'It forces you to declare each variable.
'Tools ~ Options ~ Editor. Tick 'Require Variable Declaration' to
'add it to each new module you create.
Public Sub Test()
'Set references to required files.
Dim TimFilePath As String
TimFilePath = "C:/Somepath/MyFile.xlsx"
Dim thatWB As Workbook
Set thatWB = Workbooks.Open(TimFilePath)
Dim thatWS As Worksheet
Set thatWS = thatWB.Worksheets("Sheet1")
Dim thisWB As Workbook
Set thisWB = ThisWorkbook 'Workbook containing this code.
Dim thisWS As Worksheet
Set thisWS = thisWB.Worksheets("Sheet1")
'Work on the files without selecting them.
Dim LastRow As Long
LastRow = thatWS.Cells.Find("*", , , , xlByRows, xlPrevious).Row
If LastRow = 0 Then LastRow = 1
Dim LastColumn As Long
LastColumn = thatWS.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
If LastColumn = 0 Then LastColumn = 1
Dim LastCell As Range
Set LastCell = thatWS.Cells(LastRow, LastColumn)
thatWS.Range("A2", LastCell).Copy
thisWS.Range("A2").PasteSpecial xlPasteValues
thatWB.Close False
End Sub
I have managed put a code together. It is working, but it's not very sufficient as I would need to create a 20 macros and rename the filtered text for each macro. I have two workbooks Q4 where the code saved (Q4 - cell A1:A20 filter text & B1:B20 file name) and and AA workbook where everything happening. How can I create it loops through the workbook Q4 and also the filter selects the range form workbook Q4?
Sub Delete_Rows()
Dim wb As Workbook
Dim ws As Worksheet
Dim Path As String
Dim Filename As String
Dim rng As Range
Dim lastRow As Long
Path = "C:\Users\jam_jam\Desktop\ABC\ABC1\" 'Saves file
Workbooks.Open ("C:\Users\jam_jam\Desktop\ABC\AA.xlsx") 'Opens work book
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("D1:D" & lastRow)
'''''''' filter and delete all but header row
With rng
.AutoFilter Field:=4, Criteria1:="<>*ABCD*" 'I would like to filter by range from workbook Q4
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.Name = ws.Range("D2")
ActiveSheet.Range("$A$1:$N$3000").AutoFilter Field:=4
Range("M2").Select
Filename = Workbooks("Q4.xlsm").Worksheets("333").Range("E13")
ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
End Sub
Thank you for any help?
''' With rng
.AutoFilter field:=4, Criteria1:="<>" & arr & "" 'Filters by excel value
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Below is my code, where I am facing an issue. From different workbooks I need to create 3 new sheets in new workbook. In one I have to filter data based on name of sheet from another workbook. I've stucked with copy filtered data to a new workbook. before that all works fine.
Sub Click()
Dim xRow As Long
Dim wbnew, wb1, wb2, wb3, wb4 As Workbook
Dim sht, Data As Worksheet
Dim sh1, sh2, Filter As String
Dim Name As String
Dim rng As Range
'openin files to work with
Workbooks.Open filename:="C:\Users\File1.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File2.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File3.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File4.xlsx", ReadOnly:=True
wb1 = "File1.xlsx"
wb2 = "File2.xlsx"
Set wb3 = Workbooks("File3.xlsx")
'here I create a temporary file
Set wbnew = Workbooks.Add
ActiveSheet.Name = "Data"
'defining columns I will work with
sh1 = wb3.ActiveSheet.Range("A" & i).Value
sh2 = wb3.ActiveSheet.Range("B" & i).Value
Name = wb3.ActiveSheet.Range("F" & i).Value
Filter = wb3.ActiveSheet.Range("C" & i).Value
'main goal is to copy data from 3 different files to new workbook. Below starting with copying data
Workbooks(wb1).Worksheets(sh1).Copy _
Before:=wbnew.Sheets(1)
Workbooks(wb2).Worksheets(sh2).Copy _
Before:=wbnew.Sheets(2)
'from third file I have to autofilter data for column U in File4.xlsx with criteria from File3.xlsx defined above
Set wb4 = Workbooks("File4.xlsx")
wb4.Activate
xRow = wb4.Worksheets("Transactions").Range("A1").End(xlDown).Row
wb4.Worksheets("Transactions").AutoFilterMode = False
wb4.Worksheets("Transactions").Range("A:U").AutoFilter Field:=21, Criteria1:=Filter, Operator:=xlFilterValues
'try to copy result from autofilter to new workbook to have 3 new sheets, but having an error, also I tried range copy without success
Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wbnew.Sheets("Data")
wb4.Worksheets("Transactions").AutoFilterMode = False
End Sub
I appreciate your advice. Thank you
(Written on my phone, there may be typos): Use advanced filter:-
Sub Click()
Dim xRow As Long
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wbNew as workbook
Dim sht as worksheet, Data As Worksheet
Dim sh1 as string, sh2 as string, Filter As String
Dim Name As String
Dim rng As Range
'openin files to work with
set wb1 = Workbooks.Open(filename:="C:\Users\File1.xlsx", ReadOnly:=True)
set wb2 = Workbooks.Open(filename:="C:\Users\File2.xlsx", ReadOnly:=True)
set wb3 = Workbooks.Open(filename:="C:\Users\File3.xlsx", ReadOnly:=True)
set wb4 = Workbooks.Open(filename:="C:\Users\File4.xlsx", ReadOnly:=True_
set wbNew = workbooks.add()
dim i as long 'this was missing
i = 1 'what should this be?
'defining columns I will work with
with wb3.Sheets(1)
sh1 = .Range("A" & i).Value
sh2 = .Range("B" & i).Value
Name = .Range("F" & i).Value
Filter = .Range("C" & i).Value
end with
wb3.close false
'main goal is to copy data from 3 different files to new workbook. Below starting with copying data
wb1.Worksheets(sh1).Copy Before:=wbnew.Sheets(1)
wb1.close false
wb2.Worksheets(sh2).Copy before:=wbnew.Sheets(2)
wb2.close false
'from third file I have to autofilter data for column U in File4.xlsx with criteria from File3.xlsx defined above
with wb4.Worksheets("Transactions")
xRow =.Range("A1").End(xlDown).Row
.range("Z1") = .range("U1") 'I assume Z is clear - insert heading
.range("Z2") = filter 'insert value
.range("a1:u1").copy wbnew.sheets("Data").range("a1") 'copy headings
.range("a1:u" & xrow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.range(2z1:z2"), _
CopyToRange:=wbnew.Sheets("Data").range("A1:u1")
End With
End Sub
You need to specify a range for your destination:
Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wbnew.Sheets("Data").Range("A1:U" & xRow)
I've searched everywhere to see why I'm getting this error. Basically once I get to the last line the "Selection.AutoFill Destination:=Range("G2:M" & LR)" I get the error. The code works if in a separate sub, by itself. Therefore I'm assuming the code above it is somehow affecting it?
Sub Certainsheets()
Dim Wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim LR As Long
Dim rTable As Range
Dim strCellREF2Txt As String
Dim strFILEname As String
Dim WS As Worksheet
'copy from ThisWorkbook
'Set wb2 = Workbooks(2)
Set wb2 = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan
Data.xls")
'To this
Set Wb1 = ThisWorkbook
'Copying data from Loan Data file
Set tbl = wb2.Sheets(1).Range("A1").CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Copy
'wb2.Sheets(1).Range("A1").CurrentRegion.Copy
'Pasting data into AOL DATA Tab
Wb1.Activate
Sheets("AOL DATA").Range("A10000").End(xlUp).Offset(1, 0).PasteSpecial
xlValues
'Wb1.Sheets(1).Range("A1").Select.PasteSpecial Paste:=xlPasteValues,
'Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
Application.CutCopyMode = False
wb2.Close
'REMOVING DUPLICATES
'Sheets("AOL DATA").Range("$A:$E").RemoveDuplicates Columns:=1, Header:=xlNo
'This part Autofills the formulas till the last row.
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("AOL DATA").Range("G2:M2").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("G2:M" & LR)
End sub'
Any help would be appreciated
You need to qualify your ranges with the actual sheet, otherwise VBA will default to the ActiveSheet object which may not be what you're expecting in your code.
You can re-write your code as follows:
Sub Certainsheets()
Dim loanWorkbook As Excel.Workbook
Dim aolSheet As Excel.Worksheet
Dim dataTable As Excel.Range
Set loanWorkbook = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan Data.xls")
Set aolSheet = ThisWorkbook.Sheets("AOL DATA")
Set dataTable = loanWorkbook.Sheets(1).Range("A1").CurrentRegion
With dataTable.Offset(1, 0)
aolData.Range("A" & aolData.Rows.Count).End(xlUp).Offset(1, 0).Value = _
.Resize(.Rows.Count - 1, .Columns.Count).Value
End With
loanWorkbook.Close
With aolSheet
.Range("G2:M2").AutoFill .Range("G2:M" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
End Sub
The AutoFill() method requires the source range to be included as part of the destination range. I suspect because of your code's reliance on ActiveSheet object that you're unknowingly specifying two ranges on different sheets, hence the code fails.