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
Related
I am trying to copy data from a .xlsm to a .xlsx file in SharePoint (SP). My code does several other things for moving data but the issue I am having is getting the source row from 1 doc to another doc in SP.
I am hoping someone can assist.
Sub Complete()
Dim tb1 As ListObject, tb2 As ListObject
Dim Lrow As Long, dRow As Long
Dim ws As Worksheet, ws1 As Worksheet
Dim searchRange As Range, foundCell As Range
Dim mysearch As String
Dim wb As Workbook, Scwb As Workbook
Application.DisplayAlerts = False
Set wb = ThisWorkbook
Set ws = wb.Sheets("OI")
mysearch = ws.Range("D4").Value
Set tb1 = ws.ListObjects("OITs")
Set tb2 = wb.Sheets("TDets").ListObjects("OIFinal")
Lrow = tb2.ListRows.Count
With ws
.Range("A:A").EntireColumn.Hidden = False
End With
tb1.Range.AutoFilter Field:=11, Criteria1:="<>" & vbNullString
NumRows = tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Rows.Count
tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Copy
tb2.DataBodyRange(Lrow + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
tb1.DataBodyRange.Columns(4).Resize(, 7).ClearContents
tb1.Range.AutoFilter Field:=11, Criteria1:="=" & vbNullString
With ws
.Range("A:A").EntireColumn.Hidden = True
End With
With wb.Sheets("CRqs")
Set searchRange = .Range("G1", .Range("G" & .Rows.Count).End(xlUp))
End With
Set Scwb = Workbooks.Open("https://******.sharepoint.com/sites/******/Shared%20Documents/General/NAA.xlsx") 'Opens the doc that I am looking to paste the data in
Set dRow = Scwb.Sheets("AppAccs").Cells(Scwb.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
foundCell.Offset(0, 6).Value = "Yes"
foundCell.Offset(0, -6).EntireRow.Copy _ 'this works copying the source row of data from a reference entered (mysearch)
dRow ' this now fails with a runtime error 1004
Else
MsgBox "We cannot find the ID " & mysearch & " to send. Please check ID."
End If
Application.DisplayAlerts = True
End Sub
If anyone can help or needs any further info please let me know. Thanks,
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
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'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.
I have checked a bunch of different posts and can't seem to find the exact code I am looking for. Also I have never used VBA before so I'm trying to take codes from other posts and input my info for it to work. No luck yet. At work we have a payroll system in Excel. I am trying to search for my name "Clarke, Matthew" and then copy that row and paste it to the workbook I have saved on my desktop "Total hours".
CODE
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("yourSheetName")
strSearch = "Clarke, Matthew"
With ws1
'~~> Remove any filters
.AutoFilterMode = False
'~~> I am assuming that the names are in Col A
'~~> if not then change A below to whatever column letter
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open("C:\Sample.xlsx")
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
wb2.Save
wb2.Close
End Sub
SNAPSHOT
Expanding on what timrau said in his comment, you can use the AutoFilter function to find the row with your name in it. (Note that I'm assuming you have the source workbook open)
Dim curBook As Workbook
Dim targetBook As Workbook
Dim curSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Integer
Set curBook = ActiveWorkbook
Set curSheet = curBook.Worksheets("yourSheetName")
'change the Field number to the correct column
curSheet.Cells.AutoFilter Field:=1, Criteria1:="Clarke, Matthew"
'The Offset is to remove the header row from the copy
curSheet.AutoFilter.Range.Offset(1).Copy
curSheet.ShowAllData
Set targetBook = Application.Workbooks.Open "PathTo Total Hours"
Set targetSheet = targetBook.WorkSheet("DestinationSheet")
lastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
targetSheet.Cells(lastRow + 1, 1).PasteSpecial
targetBook.Save
targetBook.Close
As you can see I put placeholders in for the specific setup of your workbook.
I know this is old, but for anyone else searching for how to do this, it can be done in a much more direct fashion:
Public Sub ExportRow()
Dim v
Const KEY = "Clarke, Matthew"
Const WS = "Sheet1"
Const OUTPUT = "c:\totalhours.xlsx"
Const OUTPUT_WS = "Sheet1"
v = ThisWorkbook.Sheets(WS).Evaluate("index(a:xfd,match(""" & KEY & """,a:a,),)")
With Workbooks.Open(OUTPUT).Sheets(OUTPUT_WS)
.[1:1].Offset(.[counta(a:a)]) = v
.Parent.Save: .Parent.Close
End With
End Sub