I'm trying to copy the formatting from specific workbook sheets from one workbook V0 then loop through a folder and paste the formatting to other workbooks.
The issue I'm having is the when I try set ws1 as one of the source sheets I get an object undefined error. The ws1 is defined at the top. When I run the code through debug all the other variables the function calls are fine and they were defined the same way.
Dim StrFile As String, SDir As String
Dim name As String
Dim Src_pg1 As String, Src_pg2 As String 'Source and Target sheets
Dim Trgt_pg1 As String, Trgt_pg2 As String
Dim ws1 As Worksheet, ws2 As Worksheet 'define worksheets
Dim ws3 As Worksheet, ws4 As Worksheet
Dim WshSource As Workbook
Dim WshTarget As Workbook
SDir = "dircectory"
StrFile = Dir(SDir + "\*")
Src_pg1 = "Homepage Update"
Trgt_pg1 = "Homepage"
Src_pg2 = "raw"
Trgt_pg2 = "sample"
Application.ScreenUpdating = False
Do While Len(StrFile) > 0
name = StrFile
Set WshSource = Workbooks.Open("directory\v0.xlsm", True, True)
Set WshTarget = Workbooks.Open(SDir + "\" + name, True, True)
Set ws1 = WshSource.Sheets(Src_pg1) '******* Where the error happens****
Set ws2 = WshTarget.Sheets(Trgt_pg1)
Set ws3 = WshSource.Sheets(Src_pg2)
Set ws4 = WshTarget.Sheets(Trgt_pg2)
ws1.Cells.Copy
ws2.Cells.PasteSpecial Paste:=xlPasteFormats 'Source format pasted
ws2.Cells.PasteSpecial Paste:=xlPasteComments 'Comments are pasted.
ws2.Cells.PasteSpecial Paste:=xlPasteValidation 'Validations are pasted
Application.CutCopyMode = False
'Application.Goto .Cells(1), 1
ws3.Cells.Copy
ws4.Cells.PasteSpecial Paste:=xlPasteFormats 'Source format pasted
ws4.Cells.PasteSpecial Paste:=xlPasteComments 'Comments are pasted.
ws4.Cells.PasteSpecial Paste:=xlPasteValidation 'Validations are pasted
Application.CutCopyMode = False
'Application.Goto .Cells(1), 1
Related
I'm trying to run a macro that I can choose an Excel file where I can filter date and copy (in a specific sheet) and paste the data back to my active workbook (in a specific sheet).
I tried various forums about workbook.open errors but still couldn't get to fix my formula.
Sub CopyFilteredValuesToActiveWorkbook()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim rngSource As Range, rngDest As Range
Dim Fname As String
Dim strName As String 'for filter
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set wbSource = Workbooks.Open(Fname) 'ERROR POINTS THIS LINE
Set wsSource = wbSource.Worksheets("Table 1")
strName = InputBox("Input Year")
wsSource.Range("A:A").AutoFilter Field:=3, Criteria1:="=* & strName & *", Operator:=xlAnd
Set rngSource = wsSource.Range("A:K")
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Sheet3")
Set rngDest = wsDest.Range("A:K")
rngDest.Value = rngSource.Value
wbSource.Close (False) 'Close without saving changes
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 want to search/loop through all the columns headers located on row 1 of the opened file and delete it if it matches dColumns, which is a list of columns I do not needed and I put in a range.
Sub LLextract()
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = ThisWorkbook.Worksheets("Consolidated Data")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row + 0
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("CSV Files (*.csv), *.csv", , _
"Select a CSV file", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
Dim dColumns As Range
Set dColumns = wb.Worksheets("LL Columns to Delete").Range("A:A")
Dim i As Integer
Dim A As Range
For i = 94 To 1 Step -1
Set A = wb2.Cells(1, i)
If wb2.Cells(1, i) = dColumns Then A.EntireColumn.Delete
Next i
'wb2.Worksheets(1).Range("A1").Select
End Sub
You can't do just Range("A"), replace that with Range("A:A").
(But what are you trying to do with dColumns?)
I solved it by just deleting the column when I open wb2. This question is no longer need to be answered or solved.
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
I have looked through this website and got a code similar to this.
My problem is that the code is opening the files but not pasting the data.
The workbook where I am trying to paste the data is TRY 5.xlsm and the range where I am pasting is B3. I am copying the data from workbook Copy of BAFD.xlsx and the range is V1:AF1.
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
With ws1.Range("V1:AF1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws2.Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
You don't need to select anything or use that With statement - does this work?
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown)).Copy
ws2.Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
EDIT: OK let's take a different approach, we'll define 2 range objects and transfer the values programatically rather than using Copy / Paste:
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngCopy As Range, rngPaste As Range
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
Set ws1 = wb1.Sheets("Calib_30Nov")
Set ws2 = wb2.Sheets("Calib29_30")
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("B3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
End Sub
EDIT - This should now work through the sheets and copy the data across for each one:
Sub CopyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngCopy As Range, rngPaste As Range
Dim strWs1 As String, strWs2 As String, i As Integer, arrSheets() As String
Dim blnExists1 As Boolean, blnExists2 As Boolean
Set wb1 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Copy of BAFD.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\43707844\Desktop\Change of weights\Svar\BAFD\Practise\TRY 5.xlsm")
'Put all BAFD.xlsx worksheet names into a string array so we can check that they exist
ReDim arrSheets(wb1.Worksheets.Count)
For i = 1 To wb1.Worksheets.Count
arrSheets(i) = wb1.Worksheets(i).Name
Next
'Loop through all sheets in TRY 5, identify numbers and transfer data across
For Each ws2 In wb2.Worksheets
Debug.Print "WS2 Name: " & ws2.Name
strWs1 = Mid(ws2.Name, 5, 2)
strWs2 = Mid(ws2.Name, 8, 2)
Debug.Print "WS2 1 Number: " & strWs1
Debug.Print "WS2 2 Number: " & strWs2
blnExists1 = False
blnExists2 = False
'Check that sheets exist in BAFD.xlsx
For i = LBound(arrSheets) To UBound(arrSheets)
If arrSheets(i) = "Calib_" & strWs1 Then blnExists1 = True
If arrSheets(i) = "Calib_" & strWs2 Then blnExists2 = True
Next
Debug.Print "WS1 Exists: " & blnExists1
Debug.Print "WS2 Exists: " & blnExists2
'If both exist, copy the values across. If they don't, move on to the next one
If blnExists1 = True And blnExists2 = True Then
'Get first sheet details
Set ws1 = wb1.Sheets("Calib_" & strWs1)
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("B3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
'Get second sheet details
Set ws1 = wb1.Sheets("Calib_" & strWs2)
Set rngCopy = ws1.Range("V1:AF1", ws1.Range("V1:AF1").End(xlDown))
Set rngPaste = ws2.Range("N3").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngPaste.Value = rngCopy.Value
End If
Next
End Sub