我对VBA很新，需要一些项目帮助 . 我需要编写一个宏来读取列C中的工作表名称，并将源工作簿中的值粘贴到目标工作簿中的范围，该范围在列D中指定 .
因此，例如，它需要复制Myworkbook book的Sheet2中的数据，并将其粘贴到他们的工作簿Sheet2的范围内 . 范围和工作表编号信息存储在单独工作簿中的位置 .
编辑：我添加了一张wbOpen的图片 .  This is it here.
Option Explicit
Sub PasteToTargetRange()
Dim arrVar As Variant 'stores all the sheets to get the copied
Dim arrVarTarget As Variant 'stores names of sheets in target workbook
Dim rngRange As Range 'each sheet name in the given range
Dim rngLoop As Range    'Range that rngRange is based in
Dim wsSource As Worksheet 'source worksheet where ranges are found
Dim wbSource As Workbook    'workbook with the information to paste
Dim wbTarget As Workbook    'workbook that will receive information
Dim strSourceFile As String 'location of source workbook
Dim strTargetFile As String 'location of source workbook
Dim wbOpen As Workbook  'Current open workbook(one with inputs)
Dim wsRange As Range 'get information from source workbook
Dim varRange As Range   'Range where values should be pasted
Dim i As Integer 'counter for For Loop
Dim wbkNewSheet As Worksheet 'create new worksheet if target workbook doesn't have
Dim wsTarget As Worksheet 'target workbook worksheet
Dim varNumber As String 'range to post
Set wbOpen = Workbooks.Open("WorkbookWithRanges.xlsx")
'Open source file
MsgBox ("Open the source file")
strSourceFile = Application.GetOpenFilename
If strSourceFile = "" Then Exit Sub
Set wbSource = Workbooks.Open(strSourceFile)
'Open target file
MsgBox ("Open the target file")
strTargetFile = Application.GetOpenFilename
If strTargetFile = "" Then Exit Sub
Set wbTarget = Workbooks.Open(strTargetFile)
'Activate transfer Workbook
wbOpen.Activate
Set wsRange = ActiveSheet.Range("C9:C20")
Set arrVarTarget = wbTarget.Worksheets
For Each varRange In wsRange
If varRange.Value = 'Target workbook worksheets
varNumber = varRange.Offset(0, -1).Value
Set wsTarget = X.Offset(0, 1)
wsSouce.Range(wsTarget).Value = varNumber
Else
wbkNewSheet = Worksheets.Add
wbkNewSheet.Name = varRange.Value
End If
Next
End Sub

    从一个工作簿各个子表中复制数据粘贴到另一个工作簿指定位置中，并对指定列进行排序，这个是我们在日常工作中经常做的，如何减少繁琐的工作步骤，提高效率，一键完成上面的工作。下面介绍通过VBA，如何自动化跨工作簿复制粘贴及排序。

    

图一





图二


需要将图一工作簿中三个子表含有公式的数据，复制粘贴数值到图二的表1，并对指定列进行降序排序，可以直接点击图二中执行的控件即可完成；以下是VBA脚本的实现。

 


Sub scopy2()
'
' 复制粘贴及排序
'
'复制粘贴
Application.ScreenUpdating = False '禁止屏幕更新数据
    Windows("xxx.xlsx").Activate '图一的表名
    Sheets("表一").Select 
    Range("B5:X19").Select
    Selection.Copy   '复制
    Windows("aaaa.xlsm").Activate '图二的表名
    Sheets("1").Select
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False   '粘贴成数值
    Windows("xxx.xlsx").Activate '图一的表名
    Sheets("表二").Select '
    Range("B5:T19").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("aaaa.xlsm").Activate '图二的表名
     Sheets("1").Select
    Range("Y6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("xxx.xlsx").Activate
    Sheets("表三").Select
    Range("B6:R20").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("aaaa.xlsm").Activate
   Sheets("1").Select
    Range("AS6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'筛选排序
Windows("aaaa.xlsm").Activate
Sheets("1").Select
    Range("A6:w20").Select
    Selection.AutoFilter '筛选
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "b6:b20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal  '筛选并对指定列进行排序
    With ActiveWorkbook.Worksheets("1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("I10").Select
    Selection.AutoFilter
    Range("y6:Aq20").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "Ab6:Ab20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("AB9").Select
    Selection.AutoFilter
    Range("As6:Bi20").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1").AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "At6:At20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("AS12").Select
    Selection.AutoFilter '去掉筛选
     Application.ScreenUpdating = True '解除禁止屏幕更新数据
End Sub

在图二的子表1的表名点右键，点击查看代码，插入模块1，粘贴上面的代码，保存。



回到表格，在开发工具里-插入-表单控件



选中控件点右键可以选择指定的宏名称，同时修改控件名称。

VBA程序集

(第2辑)

*********************************************

程序6(查找)

[程序功能] 搜索值并输入到单独的工作表中。在当前工作表的列中搜索单词(“您好”)。一旦找到匹配的数据，就将其复制到另一个工作表（“搜索结果”）中。

[条件]要求有一个命名为“搜索结果”的工作表。

[程序扩展](1)可以修改程序指定需搜索的值，也可以在该处设计一个输入框用来选取或输入要搜索的值。

(2)可以修改指定当前工作表搜索的范围。

(3)程序在搜索到指定的数据后，将会把包含此数据的整行复制到指定的工作表。可以进行修改，只复制指定的数据。同时，也可以将程序应用到设定搜索条件，搜索到满足条件的数据后，将得到整条记录结果(即查找满足条件的记录)。

[程序代码]

Option Explicit

Sub FindMe()

 Dim intS As Integer

 Dim rngC As Range

 Dim strToFind As String, FirstAddress As String

 Dim wSht As Worksheet

 Application.ScreenUpdating = False

 intS = 1

 Set wSht = Worksheets("搜索结果")

 strToFind = "您好" '指定搜索的值

 With ActiveSheet.Range("A1:C20") '可根据实际工作表改变范围.

 Set rngC = .Find(what:=strToFind, LookAt:=xlPart)

 If Not rngC Is Nothing Then

 FirstAddress = rngC.Address

 Do

 rngC.EntireRow.Copy wSht.Cells(intS, 1)

 intS = intS + 1

 Set rngC = .FindNext(rngC)

 Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress

 End If

 End With

 Application.ScreenUpdating = True

End Sub

示例文档见UploadFiles/2006-6/617259916.rar

***************************************

程序7(查找)

[程序功能] 根据值插入行。在某一列中搜索某个值，当找到该值时，就插入一个空行。

[条件] 下面的程序假设在 B 列中搜索值“1”，当找到该值时，就插入一个空行。

[程序扩展] 可以改变要搜索的值，或用对话框交互。也可改变搜索的范围。

[程序代码]

Sub 根据搜索值插入行()

 Dim Rng As Range

 Dim findstring As String


 findstring = "1" '要搜索的值，在具体应用时可根据需要改变

 Set Rng = Range("B:B").Find(What:=findstring, LookAt:=xlWhole) '根据实际改变范围

 While Not (Rng Is Nothing)

 Rng.EntireRow.Insert

 Set Rng = Range("B" & Rng.Row + 1 & ":B" & Rows.Count).Find(What:=findstring, LookAt:=xlWhole)

 Wend

End Sub

示例文档见UploadFiles/2006-6/617931442.rar

**************************************

程序8

[程序说明] 在活动工作表上的某列单元格中的数据是其它工作表名，运行程序后，工作表名单元格所在的行将被复制到与单元格内容同名的工作表中。运行程序时，源数据表必须为活动工作表。

[程序扩展] 本示例提供了一个思路，即可以将源数据工作表的数据根据特定的值进行筛选，并将筛选后的结果展示在新的不同的工作表中。

示例中值在第11列，即K列，可以根据情况改为第1列或其它列。

可根据情况进一步拓展。

[程序代码]

Sub ProcessRows()

 Dim lngRowSource As Long

 Dim lngRowTarget As Long

 Dim strStatus As String


 For lngRowSource = 1 To 25

 '工作表的名字在第11列,也可以随需要更改如改为第1列

 strStatus = ActiveSheet.Cells(lngRowSource, 11).Value

 If strStatus <> "" Then

 lngRowTarget = TargetRow(Sheets(strStatus))

 ActiveSheet.Range(Cells(lngRowSource, 1), Cells(lngRowSource, 15)).Copy _

 Sheets(strStatus).Cells(lngRowTarget, 1)

 End If

 Next


End Sub


Function TargetRow(ws As Worksheet) As Long '返回第一个空行的行号

 Dim lngLastRow As Long

 '在第11列即K列中查找空单元格,也可以根据情况改为第1列

 lngLastRow = ws.Cells(Rows.Count, 11).End(xlUp).Row

 If IsEmpty(ws.Cells(lngLastRow, 11)) Then

 TargetRow = 1

 Else

 TargetRow = lngLastRow + 1

 End If

End Function

示例文档见UploadFiles/2006-6/617710918.rar

***************************************

程序9(窗体控件——列表框/组合框)

[程序功能] 对逐层分类以及与逐层分类相似结构的表格，通过列表框/组合框来实现：第一个列表框/组合框为第一层分类，第二个列表框/组合框为第一层分类选择的类别所属的分类……依此类推。

[程序扩展] (1)本示例用列表框实现，也可用组合框实现。

(2)当数据工作表不是当前表时，可对程序进行适当修改，即列表框/组合框数据引自其它的工作表。因此，可以将数据工作表作为隐藏的数据源。

[程序代码]

Option Explicit

Private Sub UserForm_Initialize()

 AddFruit Range([A1], [A1].End(xlDown))

 ListBox1.ListIndex = 0

 With Label1

 .Caption = Cells(1, 1).Value

 .Font = "隶书"

 End With

 With Label2

 .Caption = Cells(1, 2).Value

 .Font = "隶书"

 End With

 With Label3

 .Caption = Cells(1, 3).Value

 .Font = "隶书"

 End With

End Sub


Sub AddFruit(Data As Range)

 Dim d, cel As Range

 Set d = CreateObject("Scripting.Dictionary")

 For Each cel In Data

 On Error Resume Next

 d.Add cel.Text, cel.Text

 Next

 ListBox1.List() = d.items

End Sub


'********************************

Private Sub ListBox1_Change()

 ListBox2.Clear

 AddType Range([B1], [B1].End(xlDown))

 ListBox2.ListIndex = 0

 ListBox3.ListIndex = -1

End Sub


Sub AddType(Data As Range)

 Dim d, cel As Range

 Set d = CreateObject("Scripting.Dictionary")

 For Each cel In Data

 If cel.Offset(, -1) = ListBox1 Then

 On Error Resume Next

 d.Add cel.Text, cel.Text

 End If

 Next

 ListBox2.List() = d.items

End Sub


'********************************

Private Sub ListBox2_Change()

 ListBox3.Clear

 AddMake Range([C1], [C1].End(xlDown))

 If ListBox2 <> "" Then ListBox3.ListIndex = 0

End Sub


Sub AddMake(Data As Range)

 Dim d, cel As Range

 Set d = CreateObject("Scripting.Dictionary")

 For Each cel In Data

 If cel.Offset(, -1) = ListBox2 Then

 On Error Resume Next

 d.Add cel.Text, cel.Text

 End If

 Next

 ListBox3.List() = d.items

End Sub

示例文档见UploadFiles/2006-6/617411253.rar

***************************************

程序10(窗体控件——列表框/组合框)

[程序说明] 要求能实现连续打印。Sheet2为源数据，Sheet1为结果，在Sheet1表中，网友已用数据有效性功能根据电脑编号实现不同人员的表单显示，即在下拉列表中选择电脑编号，显示相应人员的表单。如果需要将这些表单全打印出来，数据量大的话，需要在下拉列表中一个个选，然后击工具栏上的“打印”按钮，重复操作，很费时，且容易操作错误(重选、漏选)。

[程序思路] 只能使用VBA实现，考虑用户窗体中的控件。可选用组合框或列表框，这里用的是列表框。将数据源(即电脑编号)添加到列表框，然后赋值给Sheet1中“电脑编号”区域(已命名为“computer”，即设置数据有效性的区域)，在列表框项目中循环，并实现连续打印。

[界面]一个列表框，设置为隐藏；一个按钮，用于激活列表框以实现连续打印控制。

[程序代码]

Private Sub CommandButton1_Click()

 ListBox1.ListIndex = 0

End Sub

'注：ListBox1.ListIndex = 0语句不能在listBox1_Change()过程中，应在其它过程中，以激发列表框变化，从而'激活listBox_Change事件，调用事件过程中的循环语句，改变工作表中的数据，相应得到各编号表单，并打印

Private Sub listBox1_Change()

 '可以用VBA语句将工作表中的值赋给列表框，本例中在属性的RowSource进行赋值

 '将列表框中的数据与设值了有效性的单元格建立链接Range("computer").Value = ListBox1.Value

 For j = 0 To ListBox1.ListCount - 1 '从列表框中的第一项循环至最后一项

 Range("computer").Value = ListBox1.List(j) '将列表框每项数据赋值给单元格区域，工作表中产生相应表单

 Sheets(1).PrintOut Copies:=1, Collate:=True '打印

 Next j

 Unload UserForm1 '关闭窗体

End Sub

'在ThisWorkbook中设置工作簿打开时的动作

Private Sub Workbook_Open()

 UserForm1.Show

End Sub

注：load方法可以装载窗体，但窗体是隐藏的。

示例文档见UploadFiles/2006-6/617231159.rar