I am trying to create a VBA script that will gather data from four different Workbooks. For now, I am just testing the code with one Workbook, but I am receiving an error when I try to acquire the data. While I would like to retrieve the data from the four Workbooks without opening them, I will need to open them in order to find the last row of data. Here is my current code:
Public Sub GetData()
Application.ScreenUpdating = False
Dim LastRow As Integer
Dim WB As Workbook
Dim xlsPath As String
Dim xlsFilename As String
Dim SheetName As String
xlsPath = "C:\Users\a27qewt\My Documents\Document Retention\FI_DocumentRetention.xlsm"
Set WB = Workbooks.Open(xlsPath)
'Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Unprotect
LastRow = Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Cells(Rows.Count, "A").End(xlUp).Row
Workbooks("SS_Index.xlsm").Sheets("Document Index").Range(Cells(2, 1), Cells(LastRow, 5)).Value = _
Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Range(Cells(2, 1), Cells(LastRow, 5)).Value
WB.Close False
End Sub
I am receiving a 1004 application/object defined error in the Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Range... line. Any suggestions why?
You already solved your problem, but here's how I'd approach it
Public Sub GetData()
Dim LastRow As Long '<< not Integer
Dim WB As Workbook
Dim xlsPath As String
Dim xlsFilename As String
Dim SheetName As String
Dim shtSrc As Worksheet, shtDest As Worksheet, rngSrc As Range
Application.ScreenUpdating = False
xlsPath = "C:\Users\a27qewt\My Documents\Document Retention\FI_DocumentRetention.xlsm"
Set WB = Workbooks.Open(xlsPath)
Set shtSrc = WB.Sheets("S&S Document Locations")
Set shtDest = Workbooks("SS_Index.xlsm").Sheets("Document Index")
LastRow = shtSrc.Cells(shtSrc.Rows.Count, "A").End(xlUp).Row
Set rngSrc = shtSrc.Range(shtSrc.Range("A2"), _
shtSrc.Cells(LastRow, 5))
shtDest.Range("A2").Resize(rngSrc.Rows.Count, _
rngSrc.Columns.Count).Value = rngSrc.Value
WB.Close False
End Sub
Related
I'm currently working on workbook where in column A:A of worksheet("STAM-Filialen") nearly all the names of the other worksheets are. I want only those worksheets named in column("A:A") in a single PDF. The code I use know makes it a separate file for each worksheet. Is it possible to use a sort of a same code to save it as a single PDF?
Dim myCell As Range
Dim lastCell As Long
Dim PathName As String
lastCell = lastRow("STAM-Filialen")
PathName = Range("I10").Value
Worksheets("STAM-Filialen").Activate
For Each myCell In ThisWorkbook.Worksheets("STAM-Filialen").Range("A2:A" & lastCell).Cells
Dim wksName As String
wksName = myCell.Text
ThisWorkbook.Worksheets(wksName).Range("A1:P60").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PathName & "DispoPlan.Filiaal " & wksName & ".PDF"
Next
I'd recommend moving all the values to a single sheet to print. Then delete this temporary sheet when done.
Here's an example of placing each range from each sheet side by side in a new sheet.
Option Explicit
Public Sub CreateSinglePDF()
Dim ws As Range: Set ws = ThisWorkbook.Sheets(1).Range("A1:A4")
Dim rangeDict As Object: Set rangeDict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In ws
If Not rangeDict.exists(cell.Value) And cell.Value <> "" Then
rangeDict.Add cell.Value, ThisWorkbook.Sheets(cell.Value).Range("A1:A5")
End If
Next
Dim printsheet As Worksheet
Set printsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
Dim key As Variant
Dim i As Long: i = 1
For Each key In rangeDict
printsheet.Range(printsheet.Cells(1, i), printsheet.Cells(5, i)).Value = rangeDict(key).Value
i = i + 1
Next
printsheet.UsedRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\users\ryan\desktop\ExampleFile.pdf"
printsheet.Delete
End Sub
To convert multiple sheets into single pdf document,
first select multiple sheets
and use the Activesheet.ExportAsFixedFormat statement.
The print range of the page can be set in Page Setup.
Code
Sub test()
Dim WB As Workbook
Dim Ws As Worksheet
Dim sht As Worksheet
Dim PathName As String
Dim vWs() as String '<~~ Variable change
Dim rngDB As Range, rng As Range
Dim n As Integer
Set WB = ThisWorkbook
Set Ws = WB.Worksheets("STAM-Filialen")
PathName = Range("I10").Value
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
n = n + 1
ReDim Preserve vWs(1 To n)
vWs(n) = rng.text '<~~ text
Set sht = Sheets(rng.Value)
With sht.PageSetup
.PrintArea = "a1:p60"
End With
Next rng
Sheets(vWs).Select '<~~ multiple sheets select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=PathName & "DispoPlan.Filiaal.PDF"
End Sub
Worksheets("STAM-Filialen")
Specipic Sheets selected
Single pdf
I am Trying to run this Code, which will copy the Source sheet Row to Destination Sheet last Row, but my this code giving error 400 while compiling,
Advance Thanks for Help
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
Workbooks.Open (sBook_s)
sSheet_t = "cstdatalist"
sSheet_s = "cstdata"
Sheets(sSheet_s).Range("A2").Copy Destination:=Sheets(sSheet_t).Range("A2")
End Sub
Have a try on following sub.
Sub CopyData()
Dim wb As Workbook
Dim sht, shtLocal As Worksheet
Dim rngPaste As Range
Dim rngLastData, wbPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wbPath = "D:\dBook.xlsx"
Set wb = Workbooks.Open(wbPath)
Set sht = wb.Sheets(1)
Set shtLocal = ThisWorkbook.Sheets("Sheet1")
Set rngPaste = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Destination range set after last used cell of column A
rngLastData = shtLocal.Cells(Rows.Count, "A").End(xlUp).Address
shtLocal.Range("A1:" & rngLastData).Copy rngPaste
wb.Save
wb.Close
Set sht = Nothing
Set shtLocal = Nothing
Set rngPaste = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
enter code hereHere is my adjustment of your code. What I did is declared the workbooks and the worksheets separately. This way it is clear which workbook/sheet is the source and which is the destination.
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim workbook_t As Workbook
Dim sSheet_t As Worksheet
Dim sSheet_s As Worksheet
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
set workbook_t = Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
set workbook_s = Workbooks.Open (sBook_s)
set sSheet_t = workbook_t.Sheets("cstdatalist")
set sSheet_s = workbook_s.Sheets("cstdata")
sSheet_s.Range("A2").Copy Destination:=sSheet_t.Range("A2")
End Sub
I am stuck on a line and don´t know how to solve the error. I´m dividing the lines in a list by filtering different names with an advanced filter and copying the data in individual sheets, but got stuck on a line, the last one before the Next: "newWS.Range("A1").Paste". I get error 1004 from debugging:
Private Sub loopfilter()
Dim thisWB As Workbook
Dim filterws As Worksheet
Dim howto As Worksheet
Dim advfilter As Range
Dim Postenws As Worksheet
Dim VersandRange As Range
Dim rng As Range
Dim Name As String
Set thisWB = ThisWorkbook
Set filterws = thisWB.Sheets("Filtro")
Set howto = thisWB.Sheets("How to")
Set advfilter = filterws.Range("A1:AK2")
Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)")
Set VersandRange = howto.Range("J2", Cells(Rows.Count, "j").End(xlUp))
Dim newWS As Worksheet
For Each rng In VersandRange
filterws.Range("AK2") = rng.Value
Application.CutCopyMode = False
Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=advfilter, _
CopyToRange:=filterws.Range("A5"), _
Unique:=False
filterws.Range("a5").CurrentRegion.Copy
Set newWS = thisWB.Sheets.Add
newWS.Name = rng.Value
newWS.Range("A1").Paste
Next
End Sub
Any idea why its not working?
Thanks
Try this (also made a sheet reference to your definition of Versandrange). Paste is not a method of the range object.
Private Sub loopfilter()
Dim thisWB As Workbook
Dim filterws As Worksheet
Dim howto As Worksheet
Dim advfilter As Range
Dim Postenws As Worksheet
Dim VersandRange As Range
Dim rng As Range
Dim Name As String
Set thisWB = ThisWorkbook
Set filterws = thisWB.Sheets("Filtro")
Set howto = thisWB.Sheets("How to")
Set advfilter = filterws.Range("A1:AK2")
Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)")
Set VersandRange = howto.Range("J2", howto.Cells(Rows.Count, "j").End(xlUp))
Dim newWS As Worksheet
For Each rng In VersandRange
filterws.Range("AK2").value = rng.Value
Application.CutCopyMode = False
Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=advfilter, _
CopyToRange:=filterws.Range("A5"), _
Unique:=False
Set newWS = thisWB.Sheets.Add
newWS.Name = rng.Value
filterws.Range("a5").CurrentRegion.Copy newWS.Range("A1")
filterws.Range("a5").CurrentRegion.clearcontents
Next
End Sub
Searched around and found a few threads regarding VBA import the first sheet of a closed workbook, I'm trying to search through sheet of closed workbook for a set word that has been type using inputbox. Once the value is found to pull through the entire row and paste into second workbook which is active.
Below is the Code ive been working on any help would be greatly appreciated.
Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcWorksheet As Worksheet
Dim destWorksheet As Worksheet
Dim SearchRange As Range
Dim destPath As String
Dim destname As String
Dim destsheet As String
Set srcWorkbook = ActiveWorkbook
Set srcWorksheet = ActiveSheet
Dim vnt_Input As String
vnt_Input = Application.InputBox("Please Enter Client Name", "Client Name")
destPath = "C:\test\"
destname = "Test2.xlsm"
destsheet = "Sheet1"
On Error Resume Next
Set destWorkbook = Workbooks(destname)
If Err.Number <> 0 Then
Err.Clear
Set wbTarget = Workbooks.Open(destPath & destname)
CloseIt = True
End If
For Each c In Range("A2:W100").Cells
If InStr(c, "vnt_Input") > 0 Then
c.EntireRow.Copy
destWorkbook.Activate
destWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset (1) .EntireRow.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,SkipBlanks:= _
False, Transpose:=False
srcWorkbook.Activate
Kind Regards,
There are a couple changes you need to make. See whole code below. I will comment the changes:
Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcWorksheet As Worksheet
Dim destWorksheet As Worksheet
Dim SearchRange As Range
Dim destPath As String
Dim destname As String
Dim destsheet As String
Set srcWorkbook = ActiveWorkbook
Set srcWorksheet = ActiveSheet
Dim vnt_Input As String
vnt_Input = Application.InputBox("Please Enter Client Name", "Client Name")
destPath = "C:\test\"
destname = "Quick Test.xlsm"
destsheet = "Sheet1"
On Error Resume Next
Set destWorkbook = ThisWorkbook
If Err.Number <> 0 Then
Err.Clear
Set wbTarget = Workbooks.Open(destPath & destname)
CloseIt = True
End If
For Each c In wbTarget.Sheets("Companies").Range("A2:W100") 'No need for the .Cells here
If InStr(c, vnt_Input) > 0 Then 'vnt_Input is a variable that holds a string, so you can't put quotes around it, or it will search the string for "vnt_Input"
c.EntireRow.Copy
destWorkbook.Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1,0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,SkipBlanks:= _
False, Transpose:=False 'Please don't use Select and Activate. There is almost never a need for it.
End if
Next c
I try to copy a range from a workbook (opened with vba-excel) to another (thisworkbook)
Public wbKA as workbook
Sub A()
Dim oExcel As Excel.Application
KAPath = ThisWorkbook.path & "\Data.xlsx"
Set oExcel = New Excel.Application
Set wbKA = oExcel.Workbooks.Open(KAPath)
...
End Sub
with this code:
Sub Get()
Dim LastRow As Long
With wbKA.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy Destination:=ThisWorkbook.Worksheets("SheetB").Range("A6")
The line .Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy Destination:=ThisWorkbook.Worksheets("SheetB").Range("A6") is highlighted (yellow) by the debugger with the error that the copy method could not be applyed to the range object. The first copy method (just insered by me to check if the error occurs without the Destination part) runs through. I copied the code to another workbook where I apply the copy-destination copy pattern to only one workbook and it is working. Could anyone tell me, why this is not working? The wbKA workbook opens up fine and I can actually perform all I need (Search, Pasting Values into arrays and so on), just the Copy thing doesnt work.
Since you are working from Excel, you do not need to open a new instance. That is creating the copy issues. Try this (Untested)
Sub Sample()
Dim thisWb As Workbook, thatWb As Workbook
Dim thisWs As Worksheet, thatWs As Worksheet
Dim KAPath As String
Dim LastRow As Long
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("SheetB")
KAPath = ThisWorkbook.Path & "\Data.xlsx"
Set thatWb = Workbooks.Open(KAPath)
Set thatWs = thatWb.Sheets("Sheet1")
With thatWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(5, 1), .Cells(LastRow, 1)).Copy thisWs.Range("A6")
End With
End Sub
Followup from comments.
You cannot use rng.copy Dest.rng when working with different Excel instances. You will have to first copy it and then paste in the next line. See these examples
This will not work
Sub Sample()
Dim xl As New Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
xl.Visible = True
Set wb = xl.Workbooks.Add
Set ws = wb.Sheets(1)
ws.Range("A1").Value = "Sid"
ws.Range("A1").Copy ThisWorkbook.Sheets(1).Range("A1")
End Sub
This will work
Sub Sample()
Dim xl As New Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
xl.Visible = True
Set wb = xl.Workbooks.Add
Set ws = wb.Sheets(1)
ws.Range("A1").Value = "Sid"
ws.Range("A1").Copy
ThisWorkbook.Sheets(1).Range("A1").PasteSpecial xlValues
End Sub