How to write a modularized copy subroutine for cells in VBA?

问题

I need to be able to write a copy subroutine that will read in the input worksheet name and the input cells, and copy this data to a specific output sheet and output cells. This subroutine must be modularized because it will be used in mulitiple worksheets.It will only copy the data from input sheets to output sheets. Here is one I have written but it doesn't work.

Public Sub Copy_Input_Data_To_Output_Data( _
 ByVal pv_str_input_worksheet_name As String, _
 ByVal pv_str_output_worksheet_name As String, _
 ByVal pv_str_input_cell_range As String, _
 ByVal pv_str_output_cell_range As String, _
 ByRef pr_str_error_message As String)

 Worksheets(pv_str_input_worksheet_name).Range(pv_str_input_cell_range).Value  = _
 Worksheets(pv_str_output_worksheet_name).Range(pv_str_output_cell_range).Value
End Sub

Here is the code of that subroutine being applied to a input sheet.

Call Copy_Input_Data_To_Output_Data( _
 pv_str_in… _
 pv_str_output_worksheet_name:="Sheet2", _
 pv_str_input_cell_range:="B13:B17", _
 pv_str_output_cell_range:=""B17,B20,B34,B18,B21", _
 pr_str_error_message:=str_error_message)

As you can see this code is copying ranges of input cells and the data goes to specific output cells in another sheet. Please help I would greatly appericate it! :)

回答1:

Try this code out. It will work pasting a contiguous range to / from a non-contiguous range and vice versa. You could probably enhance it to even be smart enough to detect if it's two same-sized contiguous ranges, so it wouldn't loop unnecessarily.

I've also reworded the code to simplify readability.

Option Explicit

Sub RunIt()

Dim mySheet As Worksheet, yourSheet As Sheet1
Dim myRange As Range, yourRange As Range

Set mySheet = Sheets("mySheet")
Set yourSheet = Sheets("yourSheet")
Set myRange = mySheet.Range("A1:A3")
Set yourRange = yourSheet.Range("A6,B7,C8")

CopyCells mySheet, yourSheet, myRange, yourRange

End Sub

Sub CopyCells(wksIn As Worksheet, wksOut As Worksheet, rngIn As Range, rngOut As Range)

If rngIn.Cells.Count <> rngOut.Cells.Count Then

    MsgBox "Ranges are not equal. Please try again."
    Exit Sub

End If


Dim cel As Range, i As Integer, arrOut() As String
arrOut() = Split(rngOut.Address, ",")

i = 0

For Each cel In wksIn.Range(rngIn.Address)

    wksOut.Range(arrOut(i)).Value = cel.Value

    i = i + 1

Next

End Sub

回答2:

Try the Copy method of the Range object. Something like the following, provided your ranges are OK - they are copied to Range objects for readability:

Dim oRangeIn as Range
Dim oRangeOut as Range

Set oRangeIn = Worksheets(pv_str_input_worksheet_name).Range(pv_str_input_cell_range)
Set oRangeOut = Worksheets(pv_str_output_worksheet_name).Range(pv_str_output_cell_range)

oRangeIn.Copy oRangeOut

Set oRangeIn = Nothing
Set oRangeOut = Nothing

If you change the statement calling the sub it will work - but maybe not as intended:

Call Copy_Input_Data_To_Output_Data( _
    "Sheet1", _
    "Sheet2", _
    "B13:B17", _
    "B17,B20,B34,B18,B21", _
    "")

来源：https://stackoverflow.com/questions/12915415/how-to-write-a-modularized-copy-subroutine-for-cells-in-vba

标签

excel

vba

excel-vba