I am trying to copy a filtered range from a master dataset to a spreadsheet for each country (loop). I am getting a type mismatch error for Set rng1 = ws2.Range("E2:L" And lRow1) when I set a range in the filtered sheet. Can someone please help me identify the cause of the mismatch?
Sub CopyData_To_TemplateWorkbook2()
Dim wb As Workbook
Dim SavePath, TemplatePath, TemplateFile As String
Dim ws1, ws2, ws3, wbws1, wbws2, wbws3 As Worksheet
Dim rng1, rng2 As Range
Dim MSi As Variant
Dim lRow1, lRow2 As Long
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
TemplatePath = "C:\Users\xyz\Test\"
TemplateFile = "Template_blank.xlsx"
SavePath = "C:\Users\xyz\Test\"
Set ws1 = ThisWorkbook.Sheets("Lists")
Set ws2 = ThisWorkbook.Sheets("Responses 2006 2020")
ws1.Select
For i = 2 To 5 'Loop through list of country names
Set MSi = ws1.Range("A" & i)
ws2.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ws2.Range("B1").AutoFilter Field:=2, Criteria1:=MSi 'Filter Criteria1 = i
lRow1 = ws2.Range("E" & Rows.Count).End(xlUp).Row
Set rng1 = ws2.Range("E2:L" And lRow1) 'Type mismatch here
'Set rng1 = ws2.Range("E2:L") 'Application-defined or object-defined error here if used
Set wb = Workbooks.Open(Filename:=TemplatePath & "Template_blank.xlsx", Editable:=True)
Set wbws1 = wb.Sheets("Cover sheet")
Set wbws2 = wb.Sheets("Responses")
wbws1.Range("B2").Value = MSi
wbws2.Range("B2").Value = MSi
lRow2 = wbws2.Range("A" & Rows.Count).End(xlUp).Row 'But there is no last row - blank sheet
Set rng2 = wbws2.Range("A6:H") ' And lRow2 ??
rng2.Value = rng1.Value
wb.SaveAs Filename:=SavePath _
& MSi & "_text" & Format(Date, "yyyymmdd") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb.Close SaveChanges:=False
Set rng1 = Nothing
ws1.Select
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I'm trying to write a code to open mentioned workbooks one by one and move & copy a particular worksheet into a new workbook
my code for the above mentioned task runs well till it opens the first file, then it gives me the following error
method or data member not found
Sub OpenFilesMoveCopyWorksheet()
Const PTH As String = "C:\Users\xxx\yyy\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
If DFile.Worksheets.Name Like "*.cours" Then
DFile.Worksheet.copyafter: SFile.SFname
End If
DFile.Close savechanges:=False
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
Modified the code still getting "Run-time error'-2147221080 (800401a8)': Automation error"
Sub OpenFilesMoveCopyPaste()
Const PTH As String = "C:\xxx\yy\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
For I1 = 1 To SFname.Cells(Rows.Count, "B").End(xlUp).Row
SFlname2 = SFname.Range("B" & I1).Value
If Len(SFlname2) > 0 Then
Set ws = DFile.Worksheets(SFlname2)
ws.copy Before:=SFile.Sheets("sheet1")
DFile.Close savechanges:=False
End If
Next I1
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
Final Version
Sub OpenFilesMoveCopyPasteSpecial()
Const PTH As String = "C:\XXX\YY\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Application.DisplayAlerts = False
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
Debug.Print DFile.Name
SFlname2 = SFname.Range("B" & I).Value
Set ws = DFile.Worksheets(SFlname2)
ws.copy After:=SFile.Sheets("sheet1")
Cells.Select
Range("AO1").Activate
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
DFile.Close savechanges:=False
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
How do I find a value with the Find function?
I want to copy specific data from an external Excel file to the current workbook.
I added Option Explicit to test for errors but it could just spot that I didn't declare the variable. The output is the same.
Sub ReadDataFromCloseFile()
'
' ReadDataFromCloseFile Macro
'
'
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open("C:\test.xlsm", True, True)
Dim masterRow_count As Integer
masterRow_count = wb.Worksheets("Sheet1").Range("A1").End(xlDown).Row
Dim row_number As Integer
row_number = 2
Dim strSearch As String
Dim searchrange As Range
Do
Dim result As Range
strSearch = wb.Worksheets("Sheet1").Range("A" & row_number).Value
Set searchrange = src.Worksheets("Sheet1").Range("D:D")
Set result = searchrange.Find(what:=strSearch, LookIn:=xlValues, lookat:=xlValues)
If Not result Is Nothing Then
'Get the data from Asiamiles
src.Worksheets("Sheet1").Range("AB" & result.Row).Copy wb.Worksheets("Sheet1").Range("B", row_number)
src.Worksheets("Sheet1").Range("J" & result.Row).Copy wb.Worksheets("Sheet1").Range("C", row_number)
src.Worksheets("Sheet1").Range("I" & result.Row).Copy wb.Worksheets("Sheet1").Range("D", row_number)
src.Worksheets("Sheet1").Range("N" & result.Row).Copy wb.Worksheets("Sheet1").Range("E", row_number)
src.Worksheets("Sheet1").Range("AD" & result.Row).Copy wb.Worksheets("Sheet1").Range("F", row_number)
src.Worksheets("Sheet1").Range("P" & result.Row).Copy wb.Worksheets("Sheet1").Range("G", row_number)
src.Worksheets("Sheet1").Range("Q" & result.Row).Copy wb.Worksheets("Sheet1").Range("H", row_number)
End If
row_number = row_number + 1
Loop Until row_number = masterRow_count
src.Close SaveChanges:=False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
There is another problem .It could not close the Excel workbook. But that is not the largest issue.
LookAt:=xlValues should be LookAt:=xlPart or LookAt:=xlWhole, Range("B", row_number) should be Range("B" & row_number)
Option Explicit
Sub ReadDataFromCloseFile()
Const SRC_WB = "C:\test.xlsm"
Dim wb As Workbook, wbSrc As Workbook
Dim ws As Worksheet, wsSrc As Worksheet
Dim masterRow_count As Long, row_number As Long
Dim rngSearch As Range, rngResult As Range, strSearch As String
Dim i As Long, n As Long, ar, t0 As Single
t0 = Timer
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Application.ScreenUpdating = False
Set wbSrc = Workbooks.Open(SRC_WB, True, True)
Set wsSrc = wbSrc.Worksheets("Sheet1")
With wsSrc
i = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rngSearch = wsSrc.Range("D1:D" & i)
End With
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ar = Split("AB,J,I,N,AD,P,Q", ",")
With ws
masterRow_count = .Range("A" & .Rows.Count).End(xlUp).Row
For row_number = 2 To masterRow_count
strSearch = .Range("A" & row_number).Value
Set rngResult = rngSearch.Find(what:=strSearch, _
LookIn:=xlValues, lookat:=xlWhole)
If Not rngResult Is Nothing Then
'Get the data from Asiamiles
For i = 0 To UBound(ar)
.Cells(row_number, "B").Offset(0, i) = wsSrc.Cells(rngResult.Row, ar(i))
Next
n = n + 1
End If
Next
End With
wbSrc.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox row_number - 1 & " rows scanned, " & _
n & " rows updated", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
I've put together this macro using bits of code from online, and managed to get it to work on a test workbook, but it since transferring it to PERSONAL it keeps coming up with different errors. I've managed to fix a few but am now stuck on getting a "1004 - application-defined or object-defined error" on this line:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
The macro seems to run ok up to this point, generating two new worksheets with the filtered data, but then it stops at Sheet3, which it leaves blank and doesn't give a name.
If anyone could explain where I'm going wrong here that would be much appreciated, as I'm still learning!
Thanks :)
Sub NAVExportStarter()
Dim NAVExport As Workbook
Set NAVExport = ActiveWorkbook
'Filter and Copy to New Sheets
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As Worksheet
'specify sheet name in which the data is stored
Set sht = NAVExport.Sheets("249")
'change filter column in the following code
last = sht.Cells(Rows.Count, "C").End(xlUp).Row
Set rng = sht.Range("A1:O" & last)
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' Roman Imperial
Dim NAVImperial As Worksheet
Dim LIVEImperial As Workbook
Dim LIVEImperialSheet As Worksheet
Dim UniqueIDs As Range
Dim Descriptions As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set NAVExport = ThisWorkbook
Set LIVEImperial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperial.xlsm")
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Set LIVEImperialSheet = LIVEImperial.Sheets("LIVE Data")
With NAVImperial
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDs = NAVImperial.Range("B2:B" & LastRow)
Set Descriptions = NAVImperial.Range("F2:F" & LastRow)
UniqueIDs.Copy
LIVEImperialSheet.Range("A2").PasteSpecial xlPasteValues
Descriptions.Copy
LIVEImperialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperialSheet.Range("C2:O" & LastRow).FillDown
LIVEImperial.Close True
Application.ScreenUpdating = True
'Greek
Dim NAVGreek As Worksheet
Dim LIVEGreek As Workbook
Dim LIVEGreekSheet As Worksheet
Dim UniqueIDG As Range
Dim DescriptionsG As Range
Dim LastRowG As Long
Application.ScreenUpdating = False
Set LIVEGreek = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Greek.xlsx")
Set NAVGreek = NAVExport.Sheets("GREEK")
Set LIVEGreekSheet = LIVEGreek.Sheets("LIVE Data")
With NAVGreek
LastRowG = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDG = NAVGreek.Range("B2:B" & LastRowG)
Set DescriptionsG = NAVGreek.Range("F2:F" & LastRowG)
UniqueIDG.Copy
LIVEGreekSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsG.Copy
LIVEGreekSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEGreekSheet.Range("C2:R" & LastRowG).FillDown
LIVEGreek.Close True
Application.ScreenUpdating = True
'Roman Provincial
Dim NAVProvincial As Worksheet
Dim LIVEProvincial As Workbook
Dim LIVEProvincialSheet As Worksheet
Dim UniqueIDP As Range
Dim DescriptionsP As Range
Dim LastRowP As Long
Application.ScreenUpdating = False
Set LIVEProvincial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Provincial.xlsx")
Set NAVProvincial = NAVExport.Sheets("ROMAN PROVINCIAL")
Set LIVEProvincialSheet = LIVEProvincial.Sheets("LIVE Data")
With NAVProvincial
LastRowP = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDP = NAVProvincial.Range("B2:B" & LastRowP)
Set DescriptionsP = NAVProvincial.Range("F2:F" & LastRowP)
UniqueIDP.Copy
LIVEProvincialSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsP.Copy
LIVEProvincialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEProvincialSheet.Range("C2:G" & LastRowP).FillDown
LIVEProvincial.Close True
Application.ScreenUpdating = True
'Republican
Dim NAVRepublican As Worksheet
Dim LIVERepublican As Workbook
Dim LIVERepublicanSheet As Worksheet
Dim UniqueIDR As Range
Dim DescriptionsR As Range
Dim LastRowR As Long
Application.ScreenUpdating = False
Set LIVERepublican = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Republican.xlsx")
Set NAVRepublican = NAVExport.Sheets("ROMAN REPUBLIC")
Set LIVERepublicanSheet = LIVERepublican.Sheets("LIVE Data")
With NAVRepublican
LastRowR = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDR = NAVRepublican.Range("B2:B" & LastRowR)
Set DescriptionsR = NAVRepublican.Range("F2:F" & LastRowR)
UniqueIDR.Copy
LIVERepublicanSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsR.Copy
LIVERepublicanSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVERepublicanSheet.Range("C" & LastRowR).FillDown
LIVERepublican.Close True
Application.ScreenUpdating = True
'Imperatorial
Dim NAVImperatorial As Worksheet
Dim LIVEImperatorial As Workbook
Dim LIVEImperatorialSheet As Worksheet
Dim UniqueIDI As Range
Dim DescriptionsI As Range
Dim LastRowI As Long
Application.ScreenUpdating = False
Set LIVEImperatorial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperatorial.xlsx")
Set NAVImperatorial = NAVExport.Sheets("ROMAN IMPERATORIAL")
Set LIVEImperatorialSheet = LIVEImperatorial.Sheets("LIVE Data")
With NAVImperatorial
LastRowI = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDI = NAVImperatorial.Range("B2:B" & LastRowI)
Set DescriptionsI = NAVImperatorial.Range("F2:F" & LastRowI)
UniqueIDI.Copy
LIVEImperatorialSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsI.Copy
LIVEImperatorialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperatorialSheet.Range("C" & LastRowI).FillDown
LIVEImperatorial.Close True
Application.ScreenUpdating = True
'Byzantine
Dim NAVByzantine As Worksheet
Dim LIVEByzantine As Workbook
Dim LIVEByzantineSheet As Worksheet
Dim UniqueIDB As Range
Dim DescriptionsB As Range
Dim LastRowB As Long
Application.ScreenUpdating = False
Set LIVEByzantine = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Byzantine.xlsx")
Set NAVByzantine = NAVExport.Sheets("BYZANTINE")
Set LIVEByzantineSheet = LIVEByzantine.Sheets("LIVE Data")
With NAVByzantine
LastRowB = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDB = NAVByzantine.Range("B2:B" & LastRowB)
Set DescriptionsB = NAVByzantine.Range("F2:F" & LastRowB)
UniqueIDB.Copy
LIVEByzantineSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsB.Copy
LIVEByzantineSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEByzantineSheet.Range("C2:E" & LastRowB).FillDown
LIVEByzantine.Close True
Application.ScreenUpdating = True
'World
Dim NAVWorld As Worksheet
Dim LIVEWorld As Workbook
Dim LIVEWorldSheet As Worksheet
Dim UniqueIDW As Range
Dim DescriptionsW As Range
Dim LastRowW As Long
Application.ScreenUpdating = False
Set LIVEWorld = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\World.xlsx")
Set NAVWorld = NAVExport.Sheets("WORLD")
Set LIVEWorldSheet = LIVEWorld.Sheets("LIVE Data")
With NAVWorld
LastRowW = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDW = NAVWorld.Range("B2:B" & LastRowW)
Set DescriptionsW = NAVWorld.Range("F2:F" & LastRowW)
UniqueIDW.Copy
LIVEWorldSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsW.Copy
LIVEWorldSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEWorldSheet.Range("C2:E" & LastRowW).FillDown
LIVEWorld.Close True
Application.ScreenUpdating = True
End Sub
I want to create Pivot table at another xlfile, but when I Define Pivot Cache it doesn't work
Can anyone know reason?
Option Explicit
Dim date_sheet As String
Dim csv_sheet As String
Dim ptl_workbook As String
Dim csv_workbook As String
Dim insert_day As String
Sub AOI_PTL_Updater()
Dim rng As Variant
Dim myrng As Range
Dim mypath As String
Dim ptl_last_r As Integer
Dim csv_last_r As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
insert_day = Application.InputBox("ex) 20201217", "Enter the day", Left:=1000, Top:=800, Type:=2)
date_sheet = Right(insert_day, 2)
csv_sheet = InputBox("Ex) 3-1-1", "Enter sepcifitc data name", , 2000, 4000)
mypath = ThisWorkbook.Path & "\" & insert_day & "\"
csv_workbook = Dir(mypath & csv_sheet & ".csv")
ptl_workbook = "AOI_Report.xlsm"
Workbooks.Open Filename:=mypath & csv_workbook
Rows("1:6").Delete Shift:=xlUp
With Columns("B:B")
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
End With
Range("B1").FormulaR1C1 = "CRD"
Range("C1").FormulaR1C1 = "Pannel"
Range("D1").FormulaR1C1 = "Part_number"
Range("E1").FormulaR1C1 = "Real_NG"
csv_last_r = Cells(Rows.Count, 1).End(xlUp).Row
Set myrng = Range("A2:A" & csv_last_r)
Windows(ptl_workbook).Activate
ptl_last_r = Cells(Rows.Count, "A").End(xlUp).Row
Windows(csv_workbook).Activate
For Each rng In myrng
rng.Offset(0, 1).FormulaR1C1 = "=LEFT(RC[-1],FIND(""["",RC[-1],1)-1)"
rng.Offset(0, 2).FormulaR1C1 = "=MID(RC[-2],FIND(""["",RC[-2],1)+1,FIND(""]"",RC[-2],1)-(LEN(RC[-1])+2))"
rng.Offset(0, 3).FormulaR1C1 = "=INDEX('[" & ptl_workbook & "]PTL_Updater'!R1C3:R" & ptl_last_r & "C3,MATCH(""*""&RC[-2]&""*"",'[" & ptl_workbook & "]PTL_Updater'!R1C10:R" & ptl_last_r & "C10,0))"
rng.Offset(0, 4).FormulaR1C1 = "=AGGREGATE(9,6,RC20:RC28)"
Next
ActiveWorkbook.Save
Call Create_PT
Windows(csv_workbook).Activate
ActiveWindow.Close
Windows(ptl_workbook).Activate
MsgBox ("PTL Update Complete !")
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Create_PT()
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Dim PWorkbook As Workbook
Dim DWorkbook As Workbook
Dim destination_range As String
Dim D_Data As String
'Declare Variables
Windows(ptl_workbook).Activate
Sheets(date_sheet).Select
Set PWorkbook = Workbooks(ptl_workbook)
Set PSheet = PWorkbook.Worksheets(date_sheet)
Set DWorkbook = Workbooks(csv_workbook)
Set DSheet = DWorkbook.Worksheets(csv_sheet)
destination_range = PSheet.Range("B31").Address(ReferenceStyle:=xlR1C1)
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
With DSheet.Cells
D_Data = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Address(ReferenceStyle:=xlR1C1)
End With
PWorkbook.Activate
'Define Pivot Cache
Set PCache = PWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:="[" & DWorkbook.Name & "]" & DSheet.Name & "!" & D_Data). _
CreatePivotTable(TableDestination:="[" & PWorkbook.Name & "]" & PSheet.Name & "!" & destination_range, _
TableName:="PTL-data")
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.