I have several simple lines of code that should paste a section of data into the cell I selected in Sheet2:
Sub asdf()
Sheets("Sheet1").Range("A1:D5").Copy
Worksheets("Sheet2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Which just gives me application or object-defined errors.
Note: I also tried using ActiveCell which just causes this:
What is stranger is that it worked beforehand. Maybe because of saving issues?
Copy Range Values to 'the Active Cell' of Another Worksheet
Option Explicit
Sub CopyRangeValues()
' Define constants:
' Source (read (copy) from)
Const sName As String = "Sheet1"
Const srgAddress As String = "A1:D5"
' Destination (write (paste) to)
Const dName As String = "Sheet2"
' Reference our workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws') and the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range(srgAddress)
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' 2.) To reference the active cell in the destination worksheet,
' previously make sure that the destination worksheet is active.
' 1.) To activate the destination worksheet, previously make sure
' that our workbook is active.
Application.ScreenUpdating = False
' 1.) Make sure that our workbook is active.
Dim awb As Workbook: Set awb = ActiveWorkbook
If Not wb Is awb Then wb.Activate
' 2.) Make sure that the destination worksheet is active.
Dim ash As Object: Set ash = wb.ActiveSheet ' could be a chart
If Not dws Is ash Then dws.Activate
' Reference the destination first cell ('dfCell'), the active cell
' in the destination worksheet, using 'Application.ActiveCell'.
Dim dfCell As Range: Set dfCell = ActiveCell
' Reference the destination range ('drg'), the destination first cell
' resized by the number of rows and columns of the source range.
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
' Copy (by assignment) the values from the source range
' to the destination range.
drg.Value = srg.Value
' Activate the initial active sheet in our workbook
' (if it wasn't the destination worksheet).
If Not dws Is ash Then ash.Activate
' Activate the initial active workbook (if it wasn't our workbook).
If Not wb Is awb Then awb.Activate
Application.ScreenUpdating = True
' Inform.
MsgBox "Copied the values from the range '" & srgAddress _
& "' in worksheet '" & sName & "' to the range '" & drg.Address(0, 0) _
& "' in worksheet '" & dName & "' of the workbook '" & wb.Name & "'.", _
vbInformation
End Sub
Related
I have a template workbook that I need 100s of copies of ("Template"). I have the list of titles of each workbook in Sheet 2 ("Data") of this template workbook.
I've dug around on this site and found this code that does almost exactly what I need, except instead of creating a new workbook it creates new sheets within the template workbook.
Is there any change I can make to this to have it generate new workbooks?
Any help is much appreciated, I've never used macros before and anything I tried to change just breaks the code!
The code I found is below:
Sub Sample()
Dim wsToCopy As Worksheet, wsNew As Worksheet
With Sheets("Data")
LastRow = Sheets("Data").Cells(.Rows.Count, 1).End(xlUp).Row
For a = 1 To LastRow
Set wsToCopy = ThisWorkbook.Sheets("Template")
Set wsNew = ThisWorkbook.Sheets.Add
wsNew.Name = Sheets("Data").Cells(a, 1).Value
wsToCopy.Cells.Copy wsNew.Cells
Next
End With
End Sub
Create Workbooks From Template
Option Explicit
Sub CreateWorkbooksFromTemplate()
' Define constants.
Const LKP_NAME As String = "Data"
Const LKP_FIRST_CELL As String = "A2"
Const SRC_NAME As String = "Template"
Const DST_SUBFOLDER As String = "MyNewWorkbooks"
' Reference the source workbook.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
' Determine the destination path.
Dim pSep As String: pSep = Application.PathSeparator
Dim dPath As String: dPath = swb.Path & pSep & DST_SUBFOLDER & pSep
' Create the destination folder if it doesn't exist.
If Len(Dir(dPath, vbDirectory)) = 0 Then MkDir dPath
' Write the values from the lookup column to an array.
Dim lws As Worksheet: Set lws = swb.Sheets(LKP_NAME)
Dim lfCell As Range: Set lfCell = lws.Range(LKP_FIRST_CELL)
Dim llCell As Range
Set llCell = lws.Cells(lws.Rows.Count, lfCell.Column).End(xlUp)
Dim lrg As Range: Set lrg = lws.Range(lfCell, llCell)
Dim lData(): lData = lrg.Value ' assumes at least two cells
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = swb.Sheets(SRC_NAME)
' Copy the source worksheet to a new (single-worksheet) workbook.
sws.Copy
' Reference this new workbook, the destination workbook.
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
' Reference the only worksheet in the destination workbook,
' the destination worksheet.
Dim dws As Worksheet: Set dws = dwb.Sheets(1)
Dim lr As Long, dName As String
' Loop through the rows of the lookup array.
For lr = 1 To UBound(lData, 1)
' Store the current value in the lookup array as a string in a variable.
dName = CStr(lData(lr, 1))
' Check if the cell was not blank.
If Len(dName) > 0 Then ' cell was not blank
' Rename the destination worksheet.
dws.Name = dName
Application.DisplayAlerts = False ' overwrite without confirmation
' Save the destination workbook using the same name as the name
' of the destination worksheet, as a workbook without macros
' i.e. with an '.xlsx' extension.
dwb.SaveAs dPath & dName
Application.DisplayAlerts = True
'Else ' cell was blank; do nothing
End If
Next lr
' Finally, close the destination workbook.
dwb.Close SaveChanges:=False
' Inform.
MsgBox "Workbooks from template created.", vbInformation
End Sub
Hi I have created macro where it opens the sheet based on user input,
what I need is once the new sheet is opened I have some fields where user need to fill those data(Different subjects marks) and calculate the percentage using formula then I need to fill those data to another sheet named "Data" without overwriting previous data?.
Please suggest how to add data without overwriting in vba.
Sub open_sheet()
Dim sourcesheet As Worksheet
Dim ClassA As Worksheet
Dim ClassB As Worksheet
Dim ClassC As Worksheet
Set sourcesheet = Sheets("Main")
Set ClassA = Sheets("Class A")
Set ClassB = Sheets("Class B")
Set ClassC = Sheets("Class C")
If sourcesheet.Range("Class").Value = "Class A" Then
Worksheets("Class A").Activate
ElseIf sourcesheet.Range("Class").Value = "Class B" Then
Worksheets("Class B").Activate
Else:
Worksheets("Class C").Activate
End If
End Sub
Copy Cell Values to Another Worksheet
Option Explicit
Sub CopyData()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets("Main")
' Reference the source range (the values from these cells will be copied).
Dim srg As Range: Set srg = sws.Range("A3,B4,C5")
' Retrieve the destination worksheet name.
' Hopefully you have created a drop down to easily select the class.
Dim dName As String: dName = sws.Range("Class").Value
' Late at night (tired), a final check could become a life saver:
Dim Msg As Long
Msg = MsgBox("This will copy to """ & dName & """." & vbLf & vbLf _
& "Are you sure?", vbQuestion + vbYesNo)
If Msg = vbNo Then Exit Sub
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Sheets(dName)
If dws.FilterMode Then dws.ShowAllData ' 'Find' will fail if 'dws' filtered
' Reference the first (available) destination cell.
Dim dCell As Range ' First Destination Cell
With dws.UsedRange
Dim dlCell As Range ' Last Cell
Set dlCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then Exit Sub ' empty worksheet
Set dCell = dws.Cells(dlCell.Row + 1, "A") ' below last in column 'A'
End With
' Copy the values from the source to the destination cells.
Dim sCell As Range
For Each sCell In srg.Cells
dCell.Value = sCell.Value
Set dCell = dCell.Offset(, 1) ' next, adjacent to the right
Next sCell
MsgBox "Data copied.", vbInformation
End Sub
In general, here's a way to append info to a table. I would just put your average calculations in the table total row.
Option Explicit
Sub FillNewRow1()
Dim Class_A As Worksheet
Dim ClassName As String
Dim DataRange
Dim lRow As Long
ClassName = Worksheets("Master").Range("B2").Value
Set Class_A = ThisWorkbook.Worksheets(ClassName)
DataRange = Worksheets("Master").Range("B5:B8")
lRow = Class_A.Range("A" & Rows.Count).End(xlUp).Row + 1
Class_A.Range("A" & lRow).Resize(1, UBound(DataRange, 1)).Value = _
Application.Transpose(DataRange)
End Sub
But seeing as we have no idea what your source od destination data look like that's the best help I can give.
Suplimentary :
PivotCharts & Pivot Tables are awesome:
I'm very new to VBA. I'm trying to only select (Name, Age, Spent Money and Date) to a new workbook but got error message with 'Object variable or With block variable not set'.
2). Also want to get the total amount for the spent money.
Sub Table()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb as workbook
Dim nws as worksheet
Set wb = ThisWorkbook
Set ws = wb.workshets("Sheet1")
ws.copy
set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Sheet1").Range("B2").Value = nws.Range("B2").Value
With nws
.Cells().Copy
.Cells().PasteSpecial (xlPasteValues)
End With
End Sub
Create a New Table
This will create a copy of a worksheet in a new workbook, deleting the undesired columns using a list of desired columns.
Option Explicit
Sub CreateNewTable()
' 1. Define constants
Const sName As String = "Sheet1"
Const HeaderRow As Long = 1
' Write the desired titles to a variant array ('Titles').
Dim Titles() As Variant ' The order is not important!
Titles = Array("Name", "Age", "Spent Money", "Date")
' 2. Copy the worksheet.
' Reference the source workbook ('swb')
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
' Create a copy of the source worksheet in a new single-worksheet workbook.
sws.Copy
' 3. Reference the destination objects.
' Reference this new workbook, the destination workbook ('dwb').
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count) ' the last
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = dwb.Worksheets(1) ' the one and only
' Reference the destination header row range ('dhrg').
Dim dhrg As Range: Set dhrg = dws.UsedRange.Rows(HeaderRow)
' 4. Write the indexes of the matches of the header row range values
' in the titles array values, to another array ('TitleIndexes').
' Since dhrg is a single-row range, the resulting array will be
' a 1D one-based array.
Dim TitleIndexes() As Variant
TitleIndexes = Application.Match(dhrg.Value, Titles, 0)
' 5. Combine the undesired cells in a range union,
' in the destination delete range.
' Declare additional variables.
Dim ddrg As Range ' Destination Delete Range
Dim ti As Long ' Current Index of TitleIndexes
' Loop through the elements of the title indexes array.
For ti = 1 To UBound(TitleIndexes)
If IsError(TitleIndexes(ti)) Then ' is not a match ('Error 2042')
If ddrg Is Nothing Then ' first cell
Set ddrg = dhrg.Cells(ti)
Else ' all cells after the first
Set ddrg = Union(ddrg, dhrg.Cells(ti))
End If
'Else ' is a match; do nothing
End If
Next ti
' 6. Delete the entire columns of the destination delete range.
If Not ddrg Is Nothing Then ddrg.EntireColumn.Delete
' 7. Inform.
MsgBox "New table created.", vbInformation
End Sub
I am trying to run a command to open all workbooks from a query. Once open I am looking to edit the same cells in each tab for each workbook. The code below, works to open, and edit each workbook in the query when trying to update to run through each active sheet in the workbooks it will only update the first sheet. The second set is what I have tried to have it loop through each sheet.
Open and update the first active sheet in each workbook
Sub UpdateMetrics()
Dim wb As Workbook
For Each Cell In Selection
Set wb = Workbooks.Open(Cell.Value)
Range("A1").Value = "Test"
wb.Save
wb.Close
Next
End Sub
Loop through each sheet:
Sub UpdateMetricsTest()
Dim wb As Workbook
Dim ws As Worksheet
For Each Cell In Selection
Set wb = Workbooks.Open(Cell.Value)
For Each ws In Worksheets
Range("A1").Value = "Test"
Next ws
Next
End Sub
Loop Through Each Worksheet of Each Workbook
This will write a value (Test) into the same cell (A1) of each worksheet of each file (workbook) that is opened. The list of the file paths (e.g. C:\Test\Test1.xlsx) is in a column (A; more accurately A2:ALastRow) of a worksheet (Sheet1) of the workbook containing this code (ThisWorkbook).
Option Explicit
Sub UpdateMetrics()
' Source (read from)
Const sName As String = "Sheet1"
Const sCol As String = "A"
Const sfRow As Long = 2
' Destination (write to)
Const dCellAddress As String = "A1"
Const dCellValue As String = "Test"
' Reference the source (one-column) range containing the file paths.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range(sws.Cells(sfRow, sCol), _
sws.Cells(sws.Rows.Count, sCol).End(xlUp)) ' ('A2:ALastRow')
Application.ScreenUpdating = False
Dim sCell As Range
Dim dwb As Workbook
Dim dws As Worksheet
Dim dFilePath As String
' Loop through the cells of the source range.
For Each sCell In srg.Cells
dFilePath = CStr(sCell.Value) ' Tolerate error values by using 'CStr'.
If Len(dFilePath) > 0 Then ' cell is not blank
If Len(Dir(dFilePath)) > 0 Then ' file exists
On Error Resume Next ' Attempt to open the file:
Set dwb = Workbooks.Open(dFilePath)
On Error GoTo 0
If Not dwb Is Nothing Then ' file was opened
' Loop through the worksheets in the current workbook...
For Each dws In dwb.Worksheets
' ... and write the value to each worksheet's cell.
dws.Range(dCellAddress).Value = dCellValue
Next dws
dwb.Close SaveChanges:=True
Set dwb = Nothing
'Else ' file was not opened; do nothing
End If
'Else ' file does not exist; do nothing
End If
'Else ' cell is blank; do nothing
End If
Next sCell
Application.ScreenUpdating = True
' Inform.
MsgBox "Metrics updated.", vbInformation
End Sub
I have a tab called "Overview" where it asks me for the name of a project.
Once I write the project name, I want a macro to grab the project name, create a new tab, and change the name of the new tab to the project name.
Afterwards, I would like for the macro to go to another tab (let's call this tab "Template"), copy the whole worksheet, and paste the data into the newly created tab. I would like the formatting from the "Template" tab to flow to the new tab as well.
Sub AddNewTab()
Dim ws As Worksheet
Set ws = Worksheets("I DON'T KNOW WHAT TO WRITE HERE")
Rem Set working worksheets
Set WshSrc = ThisWorkbook.Worksheets("Source")
Set WshTrg = ThisWorkbook.Worksheets("Target")
'Create new tab based on project name
Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)).Name = Range("I2")
'Copy data from Template tab
Worksheets("Template").Range("A1:H12").Copy
Worksheets("I DON'T KNOW WHAT TO WRITE HERE").Range("A1").PasteSpecial
'hide gridlines in a worksheet with the project name
ws.Activate
ActiveWindow.DisplayGridlines = False
End Sub
Cell I2 in the "Overview" page is where the project name will be written.
Option Explicit
Sub AddNewTab()
Dim n As Long
With ThisWorkbook
n = .Sheets.Count
.Sheets("Template").Copy after:=.Sheets(n)
.Sheets(n + 1).Name = .Sheets("Overview").Range("I2")
End With
End Sub
Copy to a New Worksheet
Option Explicit
Sub AddNewTab()
Dim wb As Workbook: Set wb = ThisWorkbook
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets("Overview")
Dim lCell As Range: Set lCell = lws.Range("I2")
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Template")
Dim srg As Range: Set srg = sws.Range("A1:H12")
' Write the destination name to a variable.
Dim dName As String: dName = CStr(lCell.Value)
' Check if a sheet with the destination name already exists.
Dim dsh As Object ' also cover charts
On Error Resume Next
Set dsh = wb.Sheets(dName)
On Error GoTo 0
If Not dsh Is Nothing Then ' sheet already exists
MsgBox "A sheet with the name '" & dName & "' already exists.", _
vbCritical
Exit Sub
'Else ' sheet doesn't exist; do nothing
End If
' Add and rename the destination worksheet by using a variable
' (it automatically becomes the 'ActiveSheet').
Dim dws As Worksheet
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
' Copy the range.
srg.Copy dws.Range("A1")
ActiveWindow.DisplayGridlines = False
MsgBox "New worksheet added.", vbInformation
End Sub