Excel宏，基於另一個單元格值複製和粘貼多個單元格？

Question

我有2個工作表，我需要更新每週收到的另一個工作表中的數據。我想知道是否有可能將 複製到我需要更新的2個工作表的Excel文件中，然後運行一個宏來選擇我需要輸出到其他工作表的單元格。 我不知道我是否足夠清楚，下面是一個例子。

例如我有以下表單，我需要查看「名稱」列，如果名稱以「sony」開頭，則將需要的單元格複製到sony工作表中，如果它以三星形式複製單元格我需要三星表格等等。

我想複製整行然後刪除我不需要的列也將工作。

主片實例

 
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

Answer 1

我會在列A上使用AUTOFILTER來獲取我想要的行，然後我們可以只複製我們想要的列。在這個例子中，shtARR用於sheetnames和過濾器兩個，這樣會讓你的目標表名稱匹配，索尼，三星，日立等，然後試試這個：

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 

自動篩選很不錯，他們讓你以避免逐行循環，但這意味着數據中不能有空行。對數據進行排序以刪除空白（如果存在）。

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「增加一個新的case語句
7. NewTVWrkBk.Close True」關閉工作簿並保存更改
8. Set NewTVWrkBk = Nothing「加入這一行以及

這個代碼將在你sonytv等工作簿覆蓋現有的代碼...你沒有解釋，如果你想要那與否。所以我假設。