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,
Related
Today with VBA I was trying to come with something that would modify several .xlsx files in a folder and then would copy and paste the data to another worksheet. In one of the steps, I am trying to select and delete specific columns from the other Excel file based on headers' names in VBA. The columns I would like to remove are all between the headers named "Unsubscribed" and "Webinar Question 1". The issue is that when it come to this part, it gives me an error 91:
With Worksheets("Sheet0").Range("A1:BB1")
Range(Worksheets("Sheet0").Range("A1:BB1").Find(What:="Unsubscribed", LookIn:=xlValues, MatchCase:=False).Offset(0, 1), _
Cells(Worksheets("Sheet0").Cells(Worksheets("Sheet0").Rows.Count, "A").End(xlUp).Row, _
Worksheets("Sheet0").Range("A1:BB1").Find(What:="Webinar Question 1", LookIn:=xlValues, MatchCase:=False).Offset(0, -1).Column) _
).Select
End With
The whole VBA is:
Private Sub CommandButton1_Click()
Dim my_files As String
Dim folder_path As String
Dim wb As Workbook, lRow As Long
Dim ws As Worksheet, LR As Long
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
folder_path = "C:\Users\XXXX\Desktop\"
my_files = Dir(folder_path & "\*.xlsx")
Do While my_files <> vbNullString
Set wb = Workbooks.Open(folder_path & "\" & my_files)
Set ws = wb.Worksheets("Sheet0")
'INSERT COLUMN AND PASTE FILE NAME IN ALL ROWS UNTIL LAST ROW
LR = ws.Range("B9").End(xlDown).Row
ws.Columns(1).Select
ActiveCell.EntireColumn.Insert
ws.Range("A8").Value = "Title"
ws.Range("A9:A" & LR).Value = ActiveWorkbook.Name
'INSERT COLUMN AND PASTE CELL A5 VALUE IN ALL ROWS UNTIL LAST ROW
ws.Columns(2).Select
ActiveCell.EntireColumn.Insert
ws.Range("B8").Value = "Duration"
ws.Range("B9:B" & LR).Value = ws.Range("E5").Value
'DELETE A1:A7 ROWS
ws.Range("A1:A7").EntireRow.Delete
'DELETE ORGANIZATION COLUMN
Dim rng As Range
With Worksheets("Sheet0").Range("A1:BB1")
Set rng = Worksheets("Sheet0").Range("A1:BB1").Find(What:="Organization", _
lookat:=xlWhole, MatchCase:=False)
Do While Not rng Is Nothing
rng.EntireColumn.Delete
Set rng = .FindNext
Loop
End With
'SELECT AND DELETE ALL COLUMNS BETWEEN UNSUBSCRIBED AND WEBINAR QUESTION 1
With Worksheets("Sheet0").Range("A1:BB1")
Range(Worksheets("Sheet0").Range("A1:BB1").Find(What:="Unsubscribed", LookIn:=xlValues, MatchCase:=False).Offset(0, 1), _
Cells(Worksheets("Sheet0").Cells(Worksheets("Sheet0").Rows.Count, "A").End(xlUp).Row, _
Worksheets("Sheet0").Range("A1:BB1").Find(What:="Webinar Question 1", LookIn:=xlValues, MatchCase:=False).Offset(0, -1).Column) _
).Select.Delete
End With
Set wsCopy = Worksheets("Sheet0")
Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet2")
lCopyLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:BB1" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
wb.Close True
my_files = Dir()
Loop
MsgBox ("All Files Are Updated")
End Sub
For clarification, the worksheet where I have the VBA has Sheet1 and Sheet2, and the file that i am modifying has Sheet0.
What am I missing? Thank you very much and have a nice day.
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 workbook that stores quite a bit of data. I am trying to import a weekly report, paste it in a table, loop through the imported information and if a row does not match the issue key in a second table, the row needs to be copied and pasted into the second table.
Everything works until it gets to the Paste part of the code. It seems that the selection does not stay copied? I have tried several troubleshooting methods but none have worked.
Sub Get_Data_From_File()
Dim FileToOpen As Variant
Dim DAHelpPulse As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
DAHelpPulse.Sheets(1).Range("A2", Range("M2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Import").Visible = True
ThisWorkbook.Worksheets("Import").Range("A2").PasteSpecial xlPasteValues
DAHelpPulse.Close False
SearchandExtract
End If
Application.ScreenUpdating = False
End Sub
Sub SearchandExtract()
Dim datasheet As Worksheet
Dim ticketsheet As Worksheet
Dim homesheet As Worksheet
Dim issuekey As String
Dim finalrow As Integer
Dim i As Integer
Dim LastRow As Range
Dim TicketReviewTable As ListObject
Set datasheet = Sheet9
Set ticketsheet = Sheet2
Set homesheet = Sheet6
issuekey = ticketsheet.Range("B2").Value
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 2) <> issuekey Then
Range(Cells(i, 1), Cells(1, 13)).Select
Selection.Copy
Sheet2.ListObjects("TicketReview").ListRows.Add
Set TicketReviewTable = Sheet2.ListObjects("TicketReview")
Set LastRow = TicketReviewTable.ListRows(TicketReviewTable.ListRows.Count).Range
With LastRow
LastRow.PasteSpecial xlPasteValues
End With
datasheet.Select
End If
Next i
homesheet.Select
End Sub
I don't think you really need to split this up into two subs - that just means you end up re-defining items already assigned in the first step.
Untested:
Sub Get_Data_From_File()
Dim FileToOpen As Variant, rngCopy As Range, rngPaste As Range
Dim DAHelpPulse As Workbook, tbl As ListObject, issuekey, rw As Range
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", _
FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Application.ScreenUpdating = False
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
With DAHelpPulse.Sheets(1)
Set rngCopy = .Range(.Range("A2"), .Range("M2").End(xlDown))
End With
With ThisWorkbook.Worksheets("Import")
.Visible = True
Set rngPaste = .Range("A2").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
End With
rngPaste.Value = rngCopy.Value
DAHelpPulse.Close False 'no save
Set tbl = Sheet2.ListObjects("TicketReview")
issuekey = Sheet2.Range("B2").Value
For Each rw In rngPaste.Rows
If rw.Cells(2) <> issuekey Then
tbl.ListRows.Add.Range.Value = rw.Value
End If
Next rw
End If
End Sub
I have some tables from Excel that will be updated every month or so, what I am trying to do is to copy and paste those ranges from a "master workbook" to some several sheets. The way this works is I have 20 plus workbooks with those ranges "tables" already there, but I am having to manually open those workbooks then copy and paste the new values from the master workbook and close it.
Sub openwb()
Dim wkbk As Workbook
Dim NewFile As Variant
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
Dim StrFile As Variant
Dim wb2 As Excel.Workbook
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir("C:\temp\*.xlsx*")
Do While Len(StrFile) > 0
Set wb = Workbooks.Open(StrFile)
'NewFile = Application.GetOpenFilename("microsoft excel files (*.xl*), *.xl*")
'
'If NewFile <> False Then
'Set wkbk = Workbooks.Open(NewFile)
'''**********************
strSearch = "Descitption"
Set ws = Worksheets("TestCases")
With ws
Set aCell = .Columns(4).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(4).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
Set wb2 = Workbooks.Open("C:\temp\Bulk tool\test1.xlsm")
If Not rngCopy Is Nothing Then rngCopy.Copy 'paste to another worksheet Sheets("Output").Rows(1)
End With
'**************************
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir
Loop
End Sub
The range is dynamic, it can change from 2 rows to 20, but to give an example A1:K20 and it will go to the same range to another workbook.
first off let me thank everyone helping me on this.
here is what I have so far (see code)
when I run it I am getting error 1004 not sure what I changed but it was working fine, also what I am trying to do, is to copy to another worksheet.
Copying and pasting values in a worksheet uses the Range.Copy and Range.PasteSpecial.
An example code is as follows:
Sub CopyThis()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Sht1.Range("A1:D4").Copy
Sht2.Range("A1:D4").PasteSpecial xlPasteAll
End Sub
Alternatively, you can also loop through values. I usually do this out of preference because I often do "If Then" in loops
Sub CopyThis2()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Dim i As Long, j As Long
For i = 1 To 4
For j = 1 To 4
Sht2.Cells(i, j).Value = Sht1.Cells(i, j).Value
Next j
Next i
End Sub
Perhaps you can do little tricks with coding to make it faster. Like in this Answer below
Looping through files in a Folder
You can Also use Application.Screenupdating = False before the loop & True after the loop, so that your process would be way faster. In the Loop you can put the Code suggested by Parker.R ....
Also, there is no other way to copy data from workbooks without opening them in VBA.All you can do it play with the way files are being opened and closed so that the process becomes faster.
Other than Screenupdating few more properties you can Set As per this Link
Code to loop Using FSO
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder, sfol As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(f_add) ''''f_add is the Address of the folder
'''' Loop For Files in That Folder
For Each objFile In objFolder.Files
''''Your Code
Next
'''' Loop for All the Subfolders in The Folder
For Each sfol In objFolder.subfolders
''' Your Code Here
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
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