Excel根據多個文件中的選項卡名稱複製/粘貼數據

我有一個（希望）簡單的情況。我正在試圖用VBA宏自動化這個過程。Excel根據多個文件中的選項卡名稱複製/粘貼數據

我有一個Excel電子表格（我們稱之爲data.xls）具有與以下名稱的多個標籤（這只是一個例子）：

Sucralose 
Cellulose 
Dextrose

每個標籤都只是有一列數據在裏面。我想知道是否有一種簡單的方法將數據的所有選項卡複製到具有特定格式的另一個電子表格中以進行進一步操作（我們稱之爲reduction.xls），這取決於選項卡的命名。

例如：

我想複製選項卡蔗糖，葡萄糖，在reduction.xls纖維素FROM data.xls到同一個命名標籤列F（現有）的列A [蔗糖，葡萄糖，纖維素]。

我正在尋找一個「true/false」類型的語句，其中data.xls中每個選項卡的列將被粘貼到reduction.xls中，假定存在相同的確切命名選項卡，而不需要用戶的交互。

來源

2015-01-16 David Cochran

代碼下面貼有以下特點：

它用於容易地處理的選項卡的任意數量的製備。您必須僅修改3行，如下所示：1）選項卡名稱列表，2）源工作簿的名稱，3）目標工作簿的名稱。
它對目標工作簿中缺少選項卡進行「保護」。
該結構可能是不言自明的（儘管這可能是一個主觀的陳述）。

。

Sub copy_tab(ByVal wsName As String) 
    Dim wbnamesrc As String 
    Dim wbnametrg As String 
    wbnamesrc = "source.xlsm"  ' Change this line 
    wbnametrg = "Book8"  ' Change this line 
    Dim wbsrc As Workbook 
    Dim wbtrg As Workbook 
    Set wbsrc = Workbooks(wbnamesrc) 
    Set wbtrg = Workbooks(wbnametrg) 

    If (WorksheetExists(wsName, wbnametrg)) Then 
     Dim rngsrc As Range 
     Dim rngtrg As Range 
     Application.CutCopyMode = False 
     wbsrc.Worksheets(wsName).Range("A:A").Copy 
     wbtrg.Worksheets(wsName).Range("A:A").PasteSpecial 
    End If 
End Sub 

Sub copy_tabs() 
    Dim wslist As String 
    Dim sep As String 
    wslist = "Sucralose|Cellulose|Dextrose|Sheet1"  ' Change this line 
    sep = "|" 
    Dim wsnames() As String 
    wsnames = Split(wslist, sep, -1, vbBinaryCompare) 

    Dim wsName As String 
    Dim wsnamev As Variant 
    For Each wsnamev In wsnames 
     wsName = CStr(wsnamev) 
     Call copy_tab(wsName) 
    Next wsnamev 
End Sub 

Public Function str_split(str, sep, n) As String 
' From http://superuser.com/questions/483419/how-to-split-a-string-based-on-in-ms-excel 
' splits on your choice of character and returns the nth element of the split list. 
    Dim V() As String 
    V = Split(str, sep) 
    str_split = V(n - 1) 
End Function 

' From http://stackoverflow.com/a/11414255/2707864 
Public Function WorksheetExists(ByVal wsName As String, ByVal wbName As String) As Boolean 
    Dim ws As Worksheet 
    Dim ret As Boolean 
    ret = False 
    wsName = UCase(wsName) 
    For Each ws In Workbooks(wbName).Worksheets 
     If UCase(ws.Name) = wsName Then 
      ret = True 
      Exit For 
     End If 
    Next 
    WorksheetExists = ret 
End Function

來源

2015-01-17 10:13:29

就我個人而言，我會在一個單獨的工作簿中創建VBA，您可以從其他2個交互工作簿中單獨打開和執行該工作簿。

因此我定義了三個維度。 wbk =帶有代碼的工作簿。 wbk1 =您將從中複製的源工作簿。 wbk2 - 您要粘貼到的目標工作簿。

您將不得不編輯文件位置以及範圍。假如你只想要A1：A100，只要每次都是相同的行數。如果沒有，我建議增加行數遠遠超過你預計的行數，所以你要確保你不會錯過任何。

進入一個新的工作簿
按住Alt鍵，然後按F11鍵
單擊插入 - 需要
粘貼在窗口和更新文件位置和複製/粘貼範圍下面的代碼

按運行宏（綠色播放按鈕），或在代碼

Sub DataTransfer() 

Dim wbk, wbk1, wbk2 As Workbook 

    'Workbook with VBA in it. 
    Set wbk = ActiveWorkbook 

    'Define destination workbook 
    Set wbk1 = Workbooks.Open("C:\data.xls") 
    'Define Source workbook 
    Set wbk2 = Workbooks.Open("C:\reduction.xls") 




    Call wbk1.Worksheets("Sucralose").Range("A1:A100000").Copy 
    Call wbk2.Worksheets("Sucralose").Range("F1:F100000").PasteSpecial(xlPasteValues) 
    Application.CutCopyMode = False 


    Call wbk1.Worksheets("Cellulose").Range("A1:A100000").Copy 
    Call wbk2.Worksheets("Cellulose").Range("F1:F100000").PasteSpecial(xlPasteValues) 
    Application.CutCopyMode = False 


    Call wbk1.Worksheets("Dextrose").Range("A1:A100000").Copy 
    Call wbk2.Worksheets("Dextrose").Range("F1:F100000").PasteSpecial(xlPasteValues) 
    Application.CutCopyMode = False 

    End Sub

按F5鍵使用光標

來源

2015-01-16 23:37:16 Mitch

Excel根據多個文件中的選項卡名稱複製/粘貼數據

回答

相關問題