I'm looking to paste some cells from one closed workbook to another workbook.
I have managed to paste a couple of cells successfully, however, I want to copy cells starting at D9, and then every 9th until empty cells are found on SourceWb, and paste them in the other workbook TargetWb starting at column A, row 2, and so on horizontally (B2, C2, D2, etc)
Sub PullClosedData()
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Set TargetWb = ActiveWorkbook
filePath = TargetWb.Sheets("System").Range("A1").Value
Set SourceWb = Workbooks.Open(filePath)
SourceWb.Sheets("results").Range("D9").Copy
Destination:=TargetWb.Sheets("Data").Range("A2")
SourceWb.Sheets("results").Range("D18").Copy
Destination:=TargetWb.Sheets("Data").Range("B2")
SourceWb.Save
TargetWb.Save
TargetWb.Close False
MsgBox "Complete!"
End Sub
Thanks in advance for your support.
You need to use a dynamic Variant Array, and dynamic range.
Sub PullClosedData()
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim sWs As Worksheet, tWs As Worksheet
Dim i As Long, n As Long, r As Long, vR() As Variant
Set TargetWb = ActiveWorkbook
filePath = TargetWb.Sheets("System").Range("A1").Value
Set SourceWb = Workbooks.Open(filePath)
Set sWs = SourceWb.Sheets("resuts")
Set tWs = TargetWb.Sheets("Data")
With sWs
r = .Range("d" & Rows.Count).End(xlUp)
For i = 9 To r Step 9
n = n + 1
ReDim Preserve vR(1 To n) '<~~ increase dynamic array.
vR(n) = .Range("d" & i)
Next i
End With
tWs.Range("a2").Resize(1, n) = vR
SourceWb.Save
TargetWb.Save
TargetWb.Close False
MsgBox "Complete!"
End Sub
Related
I have the situation presented below in the image (Workbook 1):
and below (Workbook 2)
I want to copy my record from workbook 1 to workbook 2 if
in the Workbook 1 column A the string "surveyor" appears
the value from column B, which is exactly in the same row, where the string "suveyor" was found.
Then I would like to copy this value to my workbook 2.
I have prepared the code like this:
Sub FrontsheetAdd3()
Dim x As Worksheet, y As Worksheet, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
I have an error:
Method or data member not found
at the line
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor" Then
UPDATE:
After changing my code, which now looks like this:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Workbook, sPath As String
Dim i As Long
sPath = ThisWorkbook.Path & "\Survey_form.csv"
Set x = Workbooks.Open(sPath)
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
'Name of the sheet is the same as Name of the workbook 1
For i = 1 To 40
If x.Sheets("Survey_form").Range("A" & i).Value = "surveyor"
Then
x.Sheets("Survey_form").Rage("B" & i).Value = ("A" & i)
y.Sheets("Frontsheet").Range("D34").PasteSpecial
End If
Next i
End Sub
At the line:
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
my active workbook (Workbook2), where the macro is meant to be is closing down and error Subscript out of range emerges.
What is missig then?
Please, try the next adapted code. It will copy from the csv file in the active one and exit loop:
Sub FrontsheetAdd3()
Dim x As Workbook, y As Worksheet, ws As Worksheet, sPath As String, i As Long
sPath = ThisWorkbook.path & "\Survey_form.csv"
Set y = ActiveWorkbook.Sheets("Frontsheet") 'set to current worksheet name
Set x = Workbooks.Open(sPath): Set ws = x.Sheets(1)
For i = 1 To 40
If ws.Range("A" & i).value = "surveyor" Then
y.Range("D34").value = ws.Rage("B" & i).value: Exit For
End If
Next i
End Sub
A VBA Lookup
Use Option Explicit which forces you to declare all variables.
Use variables (more of them) to make the code more readable.
Use meaningful variable names: sPath is a great name while x and y used for workbooks are terrible.
Instead of the loop, use Application.Match.
You can basically copy in three ways: Copy, Copy with PasteSpecial or Copy by Assignment (dCell.Value = sCell.Value) the latter being the most efficient when copying only values.
Option Explicit
Sub FrontsheetAdd3()
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets("Frontsheet")
Dim dCell As Range: Set dCell = dws.Range("D34")
Dim sPath As String: sPath = dwb.Path & "\Survey_form.csv"
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = wb.Worksheets("Survey_form")
' Determine the position of the first occurence of "surveyor" in column 'A'.
Dim sIndex As Variant
sIndex = Application.Match("surveyor", sws.Columns("A"), 0)
If IsNumeric(sIndex) Then ' "suveyor" was found
Dim sCell As Range: Set sCell = sws.Rows(sIndex).Columns("B")
dCell.Value = sCell.Value
Else ' "surveyor" was not found
dCell.Value = ""
End If
swb.Close SaveChanges:=False
'dwb.Save
End Sub
I have:
Dim xlBook as Workbook
Dim xlSheet as Worksheet
Dim xlTable as ListObject
Dim xlTable Column as ListColumn
Dim xlChartObject as ChartObject
Dim xlTableObject as ListObject
Dim ObjectArray() as String
Dim ObjectIndexArray as Integer
'set the book'
Set xlBook = ThisWorkbook
'loop through each worksheet'
For each xlSheet in XlBook.Worksheets
'if we have charts
if xlSheet.ChartObjects.Count > 0 then
'grab each name
For each xlChartObject in xlSheet.ChartObjects
'update count
ObjectArrayIndex = ObjectArrayIndex + 1
ReDim Preserve ObjectArray(ObjectArrayIndex)
'add chart object to array
ObjectArray(ObjectArrayIndex) = xlChartObject.Name & "-" & xlSheet.Name & "-" & TypeName(xlChartObject)
'grab sheet
set xlSheet = xlBook.Worksheets("Export")
'grab table from sheet
set xlTable = xlSheet.ListObjects("ExportToPowerPoint")
'grab object column from table
Set xlTableColumn = xlTable.ListColumns("Object")
'set validation dropdown
With xlTableColumn.DataBodyRange.Validation
'delete old
.delete
'add new data
.add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(ObjectArray, "-")
'make sure its a dropdown
.InCellDropdown = true
end with
end sub
This code works well for grabbing charts, and similarly I utilized ListObject in order to then grab tables as well.
My Issue comes with creating another block of code to grab named ranges in excel. So not Tables or Charts
Any help would be greatly appreciated!
Activesheet.names should give array of named ranges on activeshee. Add that to for each loop and you should be done.
Names: Name, Range, Range Address
When you select a range in Excel and you use Name a range - Define name and you enter the name and press Ok, the name is 'saved' in workbook scope. So this code applies to workbook scope.
If you need to handle named ranges of worksheet scope (e.g. when you're using the same names on different worksheets), you will have to write the code somewhat differently.
The 'grab' procedures (Subs) illustrate how to return all names, range addresses and ranges (range objects) in an array and then print the contents (the Address property for ranges) to the Immediate window.
The 'get' procedure (Function) returns the array of the names and you could say it is the first 'grab' procedure written as a function.
The last procedure tests the function.
Here is another post I recently did on Names with links to some study material at the beginning.
The Code
Option Explicit
Sub grabNameNames()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim nmsCount As Long: nmsCount = wb.Names.Count
Dim nms() As String: ReDim nms(1 To nmsCount)
Dim nm As Name
Dim n As Long
For Each nm In wb.Names
n = n + 1
nms(n) = nm.Name
Next nm
If Not IsEmpty(nms) Then
Debug.Print Join(nms, vbLf)
End If
End Sub
Sub grabNameAddresses()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim nmsCount As Long: nmsCount = wb.Names.Count
Dim nma() As String: ReDim nma(1 To nmsCount)
Dim nm As Name
Dim n As Long
For Each nm In wb.Names
n = n + 1
nma(n) = nm.RefersToRange.Address(0, 0)
Next nm
If Not IsEmpty(nma) Then
Debug.Print Join(nma, vbLf)
End If
End Sub
Sub grabNameRanges()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim nmsCount As Long: nmsCount = wb.Names.Count
Dim nmr As Variant: ReDim nmr(1 To nmsCount)
Dim nm As Name
Dim n As Long
For Each nm In wb.Names
n = n + 1
Set nmr(n) = nm.RefersToRange
Next nm
If Not IsEmpty(nmr) Then
For n = 1 To UBound(nmr)
Debug.Print nmr(n).Address
Next n
End If
End Sub
Function getNameNames(wb As Workbook)
Dim nmsCount As Long: nmsCount = wb.Names.Count
Dim nms() As String: ReDim nms(1 To nmsCount)
Dim nm As Name
Dim n As Long
For Each nm In wb.Names
n = n + 1
nms(n) = nm.Name
Next nm
getNameNames = nms
End Function
Sub TESTgetNameNames()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Data As Variant: Data = getNameNames(wb)
If Not IsEmpty(Data) Then
Debug.Print Join(Data, vbLf)
End If
End Sub
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
In my first active workbook, column A has a list of numbers, starting in cell A1, and listing down a varied number of rows each time.
I would like to copy all of the column A cells containing information into another workbook (if the second workbook could remain closed during the process that would be preferable).
My desired paste location in the second workbook would be column A in the first empty row available. i.e. I want this second workbook to be a list of all of the data column A of the first workbook has ever had.
Paste this Code into a new Module in the VBA Editor of the Workbook which has the Source Data (Open VBA Editor: ALT+F11) and run the Macro "CopyToAnotherWorkbook".
before running, specify the Destination Workbook Path, hint is in the code.
Sub CopyToAnotherWorkbook()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim LastRow_wb%: LastRow_wb = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim arr() As Variant
ReDim arr(0 To LastRow_wb - 1)
For i = 1 To LastRow_wb
arr(i - 1) = ws.Cells(i, 1)
Next i
Dim wb2 As Workbook: Set wb2 = Workbooks.Open("C:\Book2.xlsx") ' <- Paste your Link to the Workbook here!
Dim ws2 As Worksheet: Set ws2 = wb2.Sheets(1)
Dim LastRow_wb2%: LastRow_wb2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
If LastRow_wb2 = 2 Then
LastRow_wb2 = 1
End If
ws2.Range("A" & LastRow_wb2 & ":A" & LastRow_wb2 + UBound(arr)).Value = WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
wb2.Close True
Set ws2 = Nothing
Set wb2 = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Long time reader and admirer of StackOverflow.
Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.
The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.
In its current form the code is executing, but not pasting anything to its destination Excel file.
I need it to
Find the data dimension in file (table)
Copy the table
Paste to destination (below previous table)
Loop through to next file
Repeat Step 1-4
The code is from:
Excel VBA: automating copying ranges from different workbooks into one final destination sheet?
Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.
Sub SourcetoDest()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sDestPath As String
Dim sSourcePath As String
Dim shDest As Worksheet
Dim rDest As Range
Dim vaFiles As Variant
Dim i As Long
'array of folder names under sDestPath
'array of file names under vaFiles
vaFiles = Array("Book1.xls")
sDestPath = "C:\Users"
sSourcePath = "C:\Users"
Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
Set shDest = wbDest.Sheets(1)
'loop through the files
For i = LBound(vaFiles) To UBound(vaFiles)
'open the source
Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))
'find the next cell in col C
Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
'write the values from source into destination
rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value
wbSource.Close False
Next i
End Sub
The below should achieve what you're after.
Option Explicit
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destFirstCell As Range
Dim destColStart As Integer, destRowStart As Long, i As Byte
Dim destPath As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
destPath = "C:\Users\"
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Worksheets(1)
With wsDest
Set destFirstCell = .Cells.Find(What:="*")
destColStart = destFirstCell.Column
destRowStart = destFirstCell.Row
.Range(Cells(destRowStart, destColStart), _
Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
End With
wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
wbDest.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function
Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.
You will need to amend the sheet name variables. Let me know if you have any questions.
You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub