copying data from one sheet to different sheets with different criteria

 Question:

I have a workbook having sheets ("1001", "1002","1003"....."1040") with a data input sheet ("input Data" having "Date", "Particulars" and "amount") to transfer to two different selected sheets.
I have created a MACRO for transfering data from sheet("Input Data") into Sheet("1001") and Sheet("1002") but next time I need to transfer data from sheet("1003") to sheet("1040) (from sheet ("Input Data") for which I have to amend SheetName in VBA Code.
I need VBA code for this requisite amendment that can be entered on the sheet("Input Data") which automatically change / amend the sheet name in (VBA code) where I want to transfer data
 




 Answers:

0 down vote

Add a button (btnCopy) to your sheet and add this code:

Private Sub btnCopy_Click()
   TransferToSheet
End Sub

Private Sub TransferToSheet()
   Dim numSheetOrigin As Integer
Do
    numSheetOrigin = AskForSheetNumber("Enter a sheet number for origin:")
Loop Until WorksheetExists(numSheetOrigin)

Dim numSheetDestiny As Integer
Do
    numSheetDestiny = AskForSheetNumber("Enter a sheet number for destiny:")
Loop Until WorksheetExists(numSheetDestiny)

Application.ScreenUpdating = False


Dim wsOrigin As Worksheet
Dim wsDestiny As Worksheet
Dim r As Long
Dim m As Long
Dim cel As Range
Set wsOrigin = Worksheets(CStr(numSheetOrigin))
Set wsDestiny = Worksheets(CStr(numSheetDestiny))

Dim intRows As Integer
'Get the row number of the last cell containing data in the sheet:
intRows = Sheets(CStr(numSheetOrigin)).UsedRange.Rows.Count

'"Date", "Particulars" and "Amount" are columns a, b and c
wsOrigin.Activate
wsOrigin.Range("a1:c" & intRows).Select
Selection.Copy
wsDestiny.Select
ActiveSheet.Paste


''Another way
'wsOrigin.Range("a1:c" & intRows).Copy
'wsDestiny.Range("a1:c" & intRows).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'wsDestiny.Close True

Dim wsName As String
wsDestiny.Name = Application.InputBox("Insert the name for the destiny sheet:")

Application.ScreenUpdating = True
End Sub


Public Function AskForSheetNumber(ByVal strText As String) As Integer
   'We only want to ask for numbers (type 1)
   AskForSheetNumber = Application.InputBox(prompt:=strText, Type:=1)
End Function


Public Function WorksheetExists(ByVal WorksheetName As Integer) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(CStr(WorksheetName)).Name <> "")
   On Error GoTo 0
End Function