I'm using a module to copy one sheet to many, but it doesn't copy the check box I have in the sheet, although if I manually select all and copy it does. Can someone explain why its not working in the VBA script, and if possible, how to get it to work?
Here is the script I am running:
Sub Button4_Click()
Const ExclusionsList As String = "Main,Source," _
& "Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday"
Dim Wbk As Workbook
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim Exclusions() As String
Dim n As Long
Set Wbk = ThisWorkbook
Set WshSrc = Wbk.Worksheets("Source")
Exclusions = Split(ExclusionsList, ",")
Application.ScreenUpdating = False
For Each WshTrg In Wbk.Worksheets
If IsError(Application.Match(WshTrg.Name, Exclusions, 0)) Then
WshSrc.Cells.Copy
With WshTrg
.Cells.PasteSpecial Paste:=xlPasteAll
Application.Goto .Cells(1), 1
End With
End If
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = True
End Sub
Related
I don't really understand VBA, all I can do is paste a code I find that does what I need (thanks to all of your excellent answers to previous questions.) Sometimes I'm able to make simple modifications.
I found a code that's perfect for what I need to do (copy one worksheet to all other sheets), but I need to exclude the first 7 sheets.
The one I'm using already excludes the source sheet, but I haven't been able to figure out how to expand that to include more.
This is the code I'm using:
Dim aWshExcluded As Variant, vWshExc As Variant
aWshExcluded = Array("Exclude(1)", "Exclude(2)")
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Rem Set Source Worksheet
Set WshSrc = ThisWorkbook.Worksheets(2)
Application.ScreenUpdating = 0
Rem Process All Worksheets
For Each WshTrg In WshSrc.Parent.Worksheets
Rem Exclude Worksheet Source
If WshTrg.Name <> WshSrc.Name Then
Rem Validate Worksheet vs Exclusion List
For Each vWshExc In aWshExcluded
If WshTrg.Name = vWshExc Then GoTo NEXT_WshTrg
Next
Rem Process Worksheet Target
With WshTrg.Cells
WshSrc.Cells.Copy
.PasteSpecial Paste:=xlPasteAll 'Everything is pasted.
Application.CutCopyMode = False
Application.Goto .Cells(1), 1
End With: End If:
NEXT_WshTrg:
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = 1
End Sub
Thank you!
Process Worksheets (With Exclusion)
A safer way would be to write the names of the exclusion worksheets to an array and use Application.Match in the loop to find a worksheet name in the array.
Using indexes instead of names is not recommended, e.g. if you move the 2nd worksheet to another position, the code will fail i.e. it will copy the wrong sheet. Also, if you move the main worksheet to a position greater than the ExclusionCount it will be overwritten.
A Quick Fix
Option Explicit
Sub CopySheet()
Const ExclusionsCount As Long = 7
Dim Wbk As Workbook
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim n As Long
Set Wbk = ThisWorkbook
Set WshSrc = Wbk.Worksheets(2)
Application.ScreenUpdating = False ' or 0
For Each WshTrg In Wbk.Worksheets
n = n + 1
If n > ExclusionsCount Then
WshSrc.Cells.Copy
With WshTrg
.Cells.PasteSpecial Paste:=xlPasteAll
Application.Goto .Cells(1), 1
End With
End If
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = True ' or "- 1" in VBA, not "1", although it works.
End Sub
EDIT
The Safer Way
Sub CopySheetWithExclusions()
Const ExclusionsList As String = "Main,Source," _
& "Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday"
Dim Wbk As Workbook
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim Exclusions() As String
Dim n As Long
Set Wbk = ThisWorkbook
Set WshSrc = Wbk.Worksheets("Source")
Exclusions = Split(ExclusionsList, ",")
Application.ScreenUpdating = False
For Each WshTrg In Wbk.Worksheets
If IsError(Application.Match(WshTrg.Name, Exclusions, 0)) Then
WshSrc.Cells.Copy
With WshTrg
.Cells.PasteSpecial Paste:=xlPasteAll
Application.Goto .Cells(1), 1
End With
End If
Next
Application.Goto Worksheets("Main").Cells(1), 1
Application.ScreenUpdating = True
End Sub
I'm new to VBA and I'm working on a project. I've searched around the internet and managed to put something together using others' examples. The basic idea is that the code copies user-selected data to a single master workbook. This is what I have so far;
Sub SelectOpenCopy()
Dim vaFiles As Variant
Dim i As Long
Dim DataBook As Workbook
Dim DataSheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vaFiles = Application.GetOpenFilename(Title:="Select files", MultiSelect:=True)
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
Set DataBook = Workbooks.Open(FileName:=vaFiles(i))
For Each DataSheet In ActiveWorkbook.Sheets
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next DataSheet
DataBook.Close savechanges:=False
Next i
End If
End Sub
Two problems with this is that:
If I run the code again and select the same files, new worksheets are made in the master workbook and that isn't what I'm going for. If those worksheets already exist, I want them to be updated instead of new ones being made. If it helps to mention, all the workbooks that need to be copied to the master file only have one worksheet each and the worksheet name matches its workbook too.
The code copies all the data, but I only need a set range ("A1:L1000").
There's a lot I don't understand about VBA, so any and all help is really appreciated!
...
Const CopyAddress = "A1:L1000"
Dim MasterSheet As Worksheet, SheetName As String, SheetExists As Boolean
...
For Each DataSheet In DataBook.Worksheets
SheetName = DataSheet.Name
SheetExists = False
For Each MasterSheet In ThisWorkbook.Worksheets
If MasterSheet.Name = SheetName Then
SheetExists = True
Exit For
End If
Next MasterSheet
If SheetExists Then
DataSheet.Range(CopyAddress).Copy MasterSheet.Range(CopyAddress).Cells(1, 1)
Else
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next DataSheet
...
When you run it, don't forget to change the path for the target workbook.
Sub moveData()
'turn off unnecessary applications to make the macro run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim target_wb As Workbook
Dim main_wb As Workbook
Dim file_sheet As Worksheet
Dim exists As Boolean
Dim next_empty_row As Long
Dim R As Range
Dim sheet_name As String
Set main_wb = ThisWorkbook
Set R = _
Application.InputBox("please select the data range:", "Kutools for Excel", , , , , , 8)
sheet_name = ActiveSheet.Name
R.Select
Selection.copy
'workbook path to paste in
Set target_wb = _
Workbooks.Open("/Users/user/Desktop/target.xlsx")
For Each file_sheet In target_wb.Sheets
Application.DisplayAlerts = False
If file_sheet.Name = main_wb.ActiveSheet.Name Then
exists = True
Exit For
Else
exists = False
End If
Next file_sheet
If exists = False Then
target_wb.Sheets.Add.Name = sheet_name
End If
next_empty_row = _
target_wb.Sheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row + 1
target_wb.Sheets(sheet_name).Cells(next_empty_row, 1).PasteSpecial
target_wb.Save
target_wb.Close
'turn on applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")
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 Workbook, source.xlsm, Worksheet "test1" Column A6:A20 that I need to copy to another WorkBook located on my C:... named dest.xlsx, Worksheet "Assets", Column "I". I need to be able to copy the data and be able to add to the column without overwriting the previous data copied. Any help would be a life saver.
Sub Align()
Dim TargetSh As String
TargetSh = "Assets"
For Each WSheet In Application.Worksheets
If WSheet.Name <> TargetSh Then
WSheet.Select
Range("A6:A20").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets(TargetSh).Select
lastRow = Range("I65532").End(xlUp).Row
Cells(lastRow + 1, 1).Select
ActiveSheet.Paste
End If
Next WSheet
End Sub
Is this what you are trying? I have not tested it but I think it should work. Let me know if you get any errors.
Sub Sample_Copy()
Dim wb As Workbook, wbTemp As Workbook
Dim ws As Worksheet, wsTemp As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("test1")
'~~> Change path as applicable
Set wbTemp = Workbooks.Open("C:\dest.xlsx")
Set wsTemp = wbTemp.Sheets("Assets")
lastRow = wsTemp.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("A6:A20").Copy wsTemp.Range("I" & lastRow)
Application.CutCopyMode = False
'~~> Cleanup
wbTemp.Close savechanges:=True
Set wb = Nothing: Set wbTemp = Nothing
Set ws = Nothing: Set wsTemp = Nothing
End Sub
HTH
Sid