Macro to fill data from sheet to another sheet - excel

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:

Related

How can I make my copy and pasting work as intended

Hello all I did a macro in VBA that should check column D for the first empty cell then paste on that row but on column C, and when adding new info in the table it should take the first empty cell again, but it is replacing data, I don't check column C for first row because I have an filled cell midway, and if data were to replace that cell it should add a new row and avoid that.
`Sub CopyPasteToAnotherSheet()
Dim sourceRange As Range
Dim targetRange As Range
Dim lastRow As Long
Dim firstEmptyRow As Long
Set sourceRange = Selection
Set targetRange = Sheets("PARKING").Range("D18")
lastRow = targetRange.End(xlDown).Row
firstEmptyRow = Sheets("PARKING").Range("D" & lastRow).End(xlUp).Row + 1
If lastRow = targetRange.Row Then
targetRange.EntireRow.Insert
End If
If Sheets("PARKING").Range("C" & firstEmptyRow).Value <> "" Then
firstEmptyRow = firstEmptyRow + 1
End If
Set targetRange = Sheets("PARKING").Range("C" & firstEmptyRow)
sourceRange.Copy
targetRange.PasteSpecial xlPasteValues
End Sub
`
I have tried to work with different search ranges but it keeps overwriting data.
also if it would keep numbering the newly added rows when adding new data it would be great I am clueless on how I should do that
Append Values
Sub AppendValues()
Const PROC_TITLE As String = "Append Values"
Const DST_NAME As String = "PARKING"
Const DST_FIRST_CELL As String = "C18"
If Selection Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf Selection Is Range Then Exit Sub ' not a range
Dim srg As Range: Set srg = Selection
Dim sws As Worksheet: Set sws = srg.Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
If Not sws.Parent Is wb Then Exit Sub ' not in this workbook
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If sws Is dws Then Exit Sub ' src. and dst. are the same worksheet
If dws.FilterMode Then dws.ShowAllData ' '.Find' will fail if 'dws' filtered
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Dim dlCell As Range
Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not dlCell Is Nothing Then
Set dfCell = dfCell.Offset(dlCell.Row - dfCell.Row + 1)
End If
Dim sarg As Range
For Each sarg In srg.Areas
dfCell.Resize(sarg.Rows.Count, sarg.Columns.Count).Value = sarg.Value
Set dfCell = dfCell.Offset(sarg.Rows.Count)
Next sarg
MsgBox "Values appended to worksheet """ & DST_NAME & """.", _
vbInformation, PROC_TITLE
End Sub

Printing Named Ranges by selecting from a list of named ranges

I have a worksheet that contains approx 50 Named Ranges and I create a list of those named Ranges which contain data and hence need to be printed. The names of those containing data are stored in a column. I need to use these names as Print Areas in a macro to loop through and print each of these ranges on a separate page. My problem is how to select each Cell Value to use as the name of a Print Area. Any assistance would be greatly appreciated
Print Named Ranges From a List
Option Explicit
Sub PrintNamedRangesFromList()
' Define constants.
Const SRC_WORKSHEET_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "A2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source single-column range (containing the names).
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_WORKSHEET_NAME)
Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_CELL)
Dim slCell As Range
Set slCell = sws.Cells(sws.Rows.Count, sfCell.Column).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
' For each cell of the source range, print the range
' defined by its name contained in the cell.
' Account for not existing names and names not referring to a range.
' Log the process ('Debug.Print') in the Immediate window (Ctrl+G).
Dim sCell As Range, prg As Range, pName As Name, pString As String
For Each sCell In srg.Cells
pString = CStr(sCell.Value)
On Error Resume Next ' prevent error if name not found
Set pName = wb.Names(pString)
On Error GoTo 0
If Not pName Is Nothing Then ' name found
On Error Resume Next ' prevent error if name not a range
Set prg = pName.RefersToRange
On Error GoTo 0
If Not prg Is Nothing Then ' name is a range
prg.PrintOut
Debug.Print "The range """ & pName.Name & """ referring to """ _
& pName.RefersTo & """ was processed."
Set prg = Nothing ' reset for the next iteration
Else ' name is not a range
Debug.Print "The name """ & pName.Name & """ refers to """ _
& pName.RefersTo & """ and was not processed."
End If
Set pName = Nothing ' reset for the next iteration
Else ' name not found
Debug.Print "The name """ & pString & """ was not found."
End If
Next sCell
' Inform.
MsgBox "Named ranges printed.", vbInformation
End Sub
Select the Cells and run this macro. It will loop through all the values and print the named ranges.
Sub printSelectedNamedRanges()
Dim rng as Range
set rng = Selection.Range
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub
You can add this on top of previous code if You have named ranges in another named Range.
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
Range(namedRange).Select
So in you case the code will be
Sub printSelectedNamedRanges()
Dim rng as Range
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
set rng = Range(namedRange)
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub

VBA copy and paste keeps spitting out application/object errors

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

VBA: duplicate an entire sheet

I have a workbook with one main index sheet and a template sheet.
I have information in my index sheet.
Each line in the main sheet should generate a new sheet.
I want to duplicate the template with all the data in there, but with a name from each line from main sheet.
I can create the sheets with the right names, but with zero data in them.
This is the VBA code to make a new sheet with the right name. I need to copy all the data into all the new sheets. It comes from this blog post by Oscar Cronquist:
'Name macro
Sub CreateSheets()
'Dimension variables and declare data types
Dim rng As Range
Dim cell As Range
'Enable error handling
On Error GoTo Errorhandling
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, _
Type:=8)
'Iterate through cells in selected cell range
For Each cell In rng
'Check if cell is not empty
If cell <> "" Then
'Insert worksheet and name the worksheet based on cell value
Sheets.Add.Name = cell
End If
'Continue with next cell in cell range
Next cell
'Go here if an error occurs
Errorhandling:
'Stop macro
End Sub
Create Template Worksheets
Sub CreateTemplateWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ash As Object: Set ash = wb.ActiveSheet
Dim lws As Worksheet: Set lws = wb.Worksheets("Main Index")
Dim lrg As Range
Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))
Dim sws As Worksheet: Set sws = wb.Worksheets("Template")
Dim lCell As Range
Dim dws As Worksheet
Dim dwsCount As Long
Dim dName As String
For Each lCell In lrg.Cells
dName = CStr(lCell.Value)
If Len(dName) > 0 Then
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If dws Is Nothing Then
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
dws.Name = dName
dwsCount = dwsCount + 1
End If
Set dws = Nothing
End If
Next lCell
ash.Select
MsgBox "Worksheets created: " & dwsCount, vbInformation
End Sub

How to copy a range from sheet to other sheets?

I'm trying to create a macro that copies a certain range (CA1:CZ99) from "Sheet A" to lots of other sheets. The names of the other sheets are based on a value of column F in "Sheet B".
The code for copying the data is easy to find.
Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets("Sheet X").Range("CA1")
But how do I loop this part over all the sheets from column F?
Copy a Range to Multiple Worksheets
Option Explicit
Sub CopyRange()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet A")
Dim srg As Range: Set srg = sws.Range("CA1:CZ99")
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets("Sheet B")
Dim lfRow As Long: lfRow = 2
Dim llRow As Long: llRow = lws.Cells(lws.Rows.Count, "F").End(xlUp).Row
If llRow < lfRow Then Exit Sub ' no data
Dim lrg As Range: Set lrg = lws.Cells(lfRow, "F").Resize(llRow - lfRow + 1)
' Copy to Destination
Dim dws As Worksheet
Dim lCell As Range
Dim lCount As Long
For Each lCell In lrg.Cells
On Error Resume Next ' check if the worksheet exists
Set dws = wb.Worksheets(CStr(lCell.Value))
On Error GoTo 0
If Not dws Is Nothing Then ' the worksheet exists
lCount = lCount + 1
srg.Copy dws.Range("CA1")
Set dws = Nothing
'Else ' the worksheet doesn't exist
End If
Next lCell
' Inform
MsgBox "Range copied to " & lCount & " worksheets.", _
vbInformation, "CopyRange"
End Sub
Specify exactly where to get the data from as a variable, and then loop over it. Example:
Sub loopCopy()
Dim shtRng As Range
Dim c As Variant
Set shtRng = Worksheets("Sheet B").Range("F1:F5")
For Each c In shtRng
Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets(c.Value).Range("CA1")
Next c
End Sub
This is a very basic setup. If the value from the column doesn't match a sheet, or if "Sheet A" or "Sheet B" change names, it will crash.
You might want to have the list adjust in size dynamically by finding last row, etc.

Resources