将数据从一张纸复制到具有不同标准的不同纸张 [英] copying data from one sheet to different sheets with different criteria

问题描述

具有数据输入表（输入数据具有日期，细节和数据）的工作簿，具有表格（1001，1002，1003.....1040）数量）转移到两个不同的选定的纸张。

我已经创建了一个MACRO，用于将数据从表格（输入数据）传输到Sheet（1001）和Sheet（1002），但下次需要将数据从表（1003）传输到表（1040）（从表（输入数据）中，我必须在VBA代码中修改SheetName。

我需要VBA代码，可以在表格（输入数据）中输入自动更改/修改（VBA代码）中要传输数据的工作表名称的必要修订

解决方案

添加一个按钮（btnCopy）到您的工作表中，并添加以下代码：

  Private Sub btnCopy_Click（）
 TransferToSheet 
 End Sub 
 
 Private Sub TransferToSheet（）
 Dim numSheetOrigin As Integer 
 Do 
 numSheetOrigin = AskForSheetNumber（输入原件号码为）
循环直到WorksheetExists（numSheetOrigin）
 
 Dim numSheetDestiny As Integer 
 Do 
 numSheetDestiny = AskForSheet Number（输入命运的表格号）
循环直到WorksheetExists（numSheetDestiny）
 
 Application.ScreenUpdating = False 
 
 
 Dim wsOrigin As工作表
 Dim wsDestiny As Worksheet 
 Dim r As Long 
 Dim m As Long 
 Dim cel As Range 
设置wsOrigin = Worksheets（CStr（numSheetOrigin））
设置wsDestiny =工作表（CStr（numSheetDestiny））
 
 Dim intRows As Integer 
'获取包含工作表中数据的最后一个单元格的行号：
 intRows = Sheets CStr（numSheetOrigin））。UsedRange.Rows.Count 
 
'日期，详细信息和金额是列a，b和c 
 wsOrigin.Activate 
 wsOrigin .Range（a1：c& intRows）。选择
 Selection.Copy 
 wsDestiny.Select 
 ActiveSheet.Paste 
 
 
另一种方式
'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（插入命运表的名称）
 
 Application.ScreenUpdating = True 
 End Sub 
 
 
公共函数AskForSheetNumber（ByVal strText As String）As Integer 
'我们只想要求数字（类型1）
 AskForSheetNumber = Application.InputBox（prompt：= strText，Type：= 1）
结束函数
 
 
公共函数WorksheetExists（ByVal WorksheetName As Integer）As Boolean 
 On Error Resume Next 
 WorksheetExists =（Sheets（CStr（WorksheetName））。Name<>）
错误GoTo 0 
结束函数
  / pre> 
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 
解决方案
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


                        
这篇关于将数据从一张纸复制到具有不同标准的不同纸张的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！