Excelmacros，复制和粘贴基于另一个单元格值的多个单元格？

我有两个工作表，我需要更新每周收到的另一个工作表中的数据。 我想知道是否有可能将数据复制到我需要更新的2个工作表的Excel文件，然后运行一个macros，select我需要输出到其他工作表的单元格。 我不知道我是否足够清楚，下面是一个例子。

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

我想复制整行，然后删除我不需要的列也将工作。

主要示例

名称---types---额外---年---功率 
索尼电视机--- LCD --- CAM --- 2009 --- 90W 

三星电视--- LED --- WIFI --- 2010 --- 70W 
索尼电视---液晶--- SAT --- 2011 --- 90W 
日立电视--- LED --- CAM --- 2012 --- 70W 

索尼图例
名称—types—年—功率

三星的例子
名称—types—年—功率

Answer 1

我将在列A上使用AUTOFILTER来获取我想要的行，然后我们可以只复制我们想要的列。 在这个例子中，shtARR用于表单名称和filter，所以使你的目标表名匹配，索尼，三星，日立等，然后试试这个：

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 

自动filter是很好的，它们允许你避免循环逐行，但这意味着你不能在数据中有空行。 对数据进行sorting以删除空白（如果存在）。

Answer 2

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

 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 

代码将从您的数据表的所有值从列A复制到E.对于每个额外的电视，您需要添加以下每个：

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新案例陈述
7. NewTVWrkBk.Close True 'closures工作簿并保存更改
8. Set NewTVWrkBk = Nothing '添加这一行

这段代码将覆盖你sonytv等工作簿中的现有代码…你没有解释，如果你想或不。 所以我假设。