vba Excel宏，根据另一个单元格值复制和粘贴多个单元格？

Excel macro, to copy and paste a multiple cells based on another cell value?

提问by Shuffz

I have 2 worksheets, I need to update with data from another worksheet I receive every week. I wonder if its possible to copy the data into the excel file with the 2 worksheets I need updating and then run a macro that selects the cells i need to output to the other worksheets. I don't know if i am being clear enough, below is an example.

我有 2 个工作表，我需要使用每周收到的另一个工作表中的数据进行更新。我想知道是否可以使用我需要更新的 2 个工作表将数据复制到 excel 文件中，然后运行一个宏来选择我需要输出到其他工作表的单元格。不知道我说得够不够清楚，下面是一个例子。

For example I have the following sheet, I need to look though the "name" column and if the name begins with "sony", copy the cells i need to the sony worksheet, if it begins with Samsung copy the cells i need to the Samsung sheet and so on.

例如，我有以下工作表，我需要查看“名称”列，如果名称以“sony”开头，请将我需要的单元格复制到 sony 工作表中，如果以三星开头，则将我需要的单元格复制到三星片材等。

I suppose that copying the whole row then deleting the columns I don't need will also work.

我想复制整行然后删除我不需要的列也可以。

Main Sheet Example

主表示例

Name            --- Type --- Extra --- Year --- Power 
Sony TV         --- LCD  --- CAM   --- 2009 --- 90W

Samsung TV      --- LED  --- WIFI   --- 2010 --- 70W 
Sony TV         --- LCD  --- SAT   --- 2011 --- 90W 
Hitachi TV      --- LED  --- CAM   --- 2012  --- 70W 


Sony Sheet Example
Name   --- Type  --- Year --- Power 

Samsung sheet Example
Name   --- Type  --- Year --- Power 

回答by Hassan

you can try the code below. run it on the Datasheet you receive

你可以试试下面的代码。在您收到的数据表上运行它

Public Sub CopyDataFromDataWorkBook()
Dim counter As Integer
Dim SonyWrkBk As Workbook
Dim SamsungWrkBk As Workbook
Dim SonySheet As Worksheet 'declare sonysheet and samsung (add more if you need)
Dim SamsungSheet As Worksheet
Dim datasheet As Worksheet
    '****Variables
    Set datasheet = ActiveSheet
    Set SonyWrkBk = Workbooks.Open("C:\Sony TV.xls") 'opens up workbook stored at C:\ (Addmore if you need)
    Set SamsungWrkBk = Workbooks.Open("C:\Samsung TV.xls")

    Set SonySheet = SonyWrkBk.Sheets(1) 'opens up the worksheet we are working on, in this case the first worksheet
    Set SamsungSheet = SamsungWrkBk.Sheets(1)

    last = datasheet.Cells(Rows.Count, "A").End(xlUp).row 'on your data sheet, we can find the last row by using ColA
    counter = 2
    SonyCounter = 2    'this is to determine how far down are we in the sony file
    SamsungCounter = 2
    '***
    For i = last To 2 Step -1
        Select Case datasheet.Range("A" & counter).Value
        Case "Sony TV"
          SonySheet.Range("A" & SonyCounter, "E" & SonyCounter).Value = ActiveSheet.Range("A" & counter, "E" & counter).Value
          SonyCounter = SonyCounter + 1
        Case "Samsung TV"
          SamsungSheet.Range("A" & SamsungCounter, "E" & SamsungCounter).Value = ActiveSheet.Range("A" & counter, "E" & counter).Value
          SamsungCounter = SamsungCounter + 1
        End Select
        counter = counter + 1
    Next i
SonyWrkBk.Close True 'the true bit will save the workbook
SamsungWrkBk.Close True 'if you set to false or nothing, you will be asked everytime if you wana save changes
Set SamsungWrkBk = Nothing
Set SonyWrkBk = Nothing 'needed to free up memory
End Sub

The code will copy all values from your data sheet from Column A to E. For each extra TV, you need to add the following for each:

该代码会将数据表中的所有值从 A 列复制到 E。对于每台额外的电视，您需要为每台电视添加以下内容：

1. Dim NewTVWrkBk As Workbook'declare the new tv workbook
2. Dim NewTVSheet As Worksheet'declare the new tv worksheet
3. Set NewTVWrkBk = Workbooks.Open("C:\New TV.xls")open the workbook
4. Set NewTVSheet = NewTVWrkBk.Sheets(1)'open the first worksheet (if thats where you want to store the data
5. NewTVCounter =2'set up the new tv counter
6. Case "New TV" NewTVSheet.Range("A" & NewTVCounter, "E" & NewTVCounter).Value = ActiveSheet.Range("A" & counter, "E" & counter).Value NewTVCounter = NewTVCounter + 1'add a new case statement
7. NewTVWrkBk.Close True'Close the workbook and Save changes
8. Set NewTVWrkBk = Nothing'add this line as well

1. Dim NewTVWrkBk As Workbook'声明新的电视工作簿
2. Dim NewTVSheet As Worksheet'声明新的电视工作表
3. Set NewTVWrkBk = Workbooks.Open("C:\New TV.xls")打开工作簿
4. Set NewTVSheet = NewTVWrkBk.Sheets(1)'打开第一个工作表（如果这是你想要存储数据的地方
5. NewTVCounter =2'设置新的电视柜台
6. Case "New TV" NewTVSheet.Range("A" & NewTVCounter, "E" & NewTVCounter).Value = ActiveSheet.Range("A" & counter, "E" & counter).Value NewTVCounter = NewTVCounter + 1'添加一个新的case语句
7. NewTVWrkBk.Close True'关闭工作簿并保存更改
8. Set NewTVWrkBk = Nothing'也添加这一行

this code will overwrite existing code in you sonytv etc workbooks... you didnt explain if you wanted that or not. so i assumed.

此代码将覆盖您 sonytv 等工作簿中的现有代码……您没有解释是否需要。所以我假设。

回答by Jerry Beaucaire

I would use an AUTOFILTER on column A to get just the rows I want visible, then we can copy just the columns we want. In this example, the shtARR is used for both the sheetnames and the filter, so make your target sheet names match, Sony, Samsung, Hitachi, etc. Then try this:

我会在 A 列上使用 AUTOFILTER 来获取我想要可见的行，然后我们可以只复制我们想要的列。在本例中，shtARR 用于工作表名称和过滤器，因此使您的目标工作表名称匹配，Sony、Samsung、Hitachi 等。然后试试这个：

Sub VendorFilters()
Dim ws2 As Worksheet, LR As Long
Dim shtARR As Variant, i As Long

'assuming these are the names of the target sheets, we can use for filtering, too
shtARR = Array("Sony", "Samsung", "Hitachi")

With Sheets("Main")                 'filtering the sheet with the original data
    .AutoFilterMode = False         'turn off any prior filters
    .Rows(1).AutoFilter             'new filter

    For i = LBound(shtARR) To UBound(shtARR)
        Set ws2 = Sheets(shtARR(i))         'if you get an error here, check the sheet names

        .Rows(1).AutoFilter 1, shtARR(i) & "*"          'new filter for current value
        LR = .Range("A" & .Rows.Count).End(xlUp).Row    'last row with visible data

        If LR > 1 Then                  'if any rows visible, copy wanted columns to sheet2
            .Range("A2:A" & LR).Copy ws2.Range("A1")
            .Range("C2:D" & LR).Copy ws2.Range("B1")
        End If
    Next i

    .AutoFilterMode = False             'remove the filter
End With

End Sub

Autofilters are nice, they allow you to avoid looping row by row, but it means you can't have blank rows in the data. Sort the data before to remove the blanks, if present.

自动过滤器很好，它们允许您避免逐行循环，但这意味着数据中不能有空行。之前对数据进行排序以删除空白（如果存在）。