[英]Excel VBA - Copying all Worksheets from a specific workbook into an active workbok
[英]Excel VBA - rename all worksheets from col of new names in another workbook
這個問題與使用VBA重命名列表中的多個工作表大致相似,但差異太大,無法從該問題中獲得答案。
我經常需要在各種傳入的工作簿中重命名數十個工作表。
我希望通過以下方式重命名所有工作表:首先將所有工作表名稱復制到secondWorkbook.sheets(1)colA中,在ColB中手動創建新名稱,然后運行第二個宏以更新originalWorkbook中的名稱。
我被困在第二個宏上,但是將在下面提供兩個宏。 如果有人用更短/更好的方式編寫這些宏,那么我全是眼睛。
第一個宏-將所有工作表名稱復制到新的workbook.sheet(1).colA中。 這將起作用,並使用ColA中的選項卡名稱創建一個新的未保存工作簿
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim tst, tmp, allTabNames As String
Dim i, cnt, cnt2 As Long
Dim wb, wbTmp As Workbook, xWs, ws1 As Worksheet
Dim arrOldNames, arrNewNames As Variant
ReDim arrOldNames(999)
cnt = 0
With ActiveWorkbook
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
arrOldNames(cnt) = xWs.Name
cnt = cnt + 1
End If
Next
End With
ReDim Preserve arrOldNames(cnt - 1)
cnt2 = 1
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
For i = 1 To cnt
ws1.Range("A" & i).Value = arrOldNames(i - 1)
Next
MsgBox "Done. Copied " & cnt & " tab names."
End Sub
這是我堅持的宏。 這兩個工作簿都在屏幕上打開,我不介意編輯宏以提供工作簿名稱。 不確定如何引用未保存的工作簿,其名稱類似於“ Book4-Microsoft Excel”,因此我將其保存為Temp.xlsx並將其引用為namesWb 。 帶有要重命名的選項卡的工作簿稱為targetWb
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb, targetWb As Workbook
Dim colA, colB As Variant
Set namesWb = Windows("Temp.xlsx")
Set targetWb = ActiveWorkbook
ReDim colA(999), colB(999)
cnt = 0
With namesWb
Sheets(1).Activate
For i = 1 To 999
If Range("A" & i).Value = "" Then Exit For
colA(i - 1) = Range("A" & i).Value
colB(i - 1) = Range("B" & i).Value
cnt = cnt + 1
Next
ReDim Preserve colA(cnt)
ReDim Preserve colB(cnt)
End With
For each oldname in colA()
'Stuck here...
Next
End Sub
我意識到我可以再次遍歷targetWb,並為每個選項卡名稱在ColA()中找到該選項卡名稱的位置,並使用來自tabB()的相同位置名稱對其重命名-但我想知道是否有更快/更好的選擇做到這一點的方法。
您可以像這樣循環瀏覽活動的工作簿:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name Like "Book*" Then
Set tempWB = wb
End If
Next wb
End Sub
編輯:由於您只有兩個打開的工作簿,因此可以縮短:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook ' MAKE SURE THIS IS CORRECT!! May need `ThisWorkbook` if the new temporary one becomes the active one.
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name <> mainWB.Name And wb.Name <> "PERSONAL.XLSB" Then
Set tempWB = wb
' Now do whatever you need with the Temporary workbook.
End If
Next wb
End Sub
我對您的Sub
都進行了重構,以顯示一種更強大的方法。
Rename...
現在跳過所有缺少的新名稱 Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim wbToRename As Workbook
Dim wbTmp As Workbook
Dim xWs As Worksheet
Dim ws1 As Worksheet
Dim arrOldNames As Variant
Dim arrNewNames As Variant
Dim cnt As Long
Set wbToRename = ActiveWorkbook
With wbToRename
' Size array based on number of sheets in workbook
ReDim arrOldNames(1 To .Worksheets.Count, 1 To 1)
cnt = 0
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
cnt = cnt + 1
arrOldNames(cnt, 1) = xWs.Name
End If
Next
End With
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
'Place data in sheet in one go
ws1.Cells(1, 1) = wbToRename.Name
ws1.Cells(2, 1).Resize(UBound(arrOldNames, 1), 1) = arrOldNames
MsgBox "Done. Copied " & cnt & " tab names."
'Save workbook
wbTmp.SaveAs Filename:=wbToRename.Path & "\Temp", FileFormat:=xlOpenXMLWorkbook
End Sub
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb As Workbook
Dim targetWb As Workbook
Dim wsNames As Worksheet
Dim ws As Worksheet
Dim NamesList As Variant
Dim cnt As Long
Dim i As Long
Set namesWb = Application.Workbooks("Temp.xlsx")
Set targetWb = Application.Workbooks(namesWb.Worksheets(1).Cells(1, 1).Value)
cnt = 0
Set wsNames = namesWb.Worksheets(1)
With wsNames
'Get Names into one variable, based on actual number of rows
NamesList = wsNames.Range(wsNames.Cells(2, 2), wsNames.Cells(wsNames.Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(NamesList, 1)
' Check if the Name has been entered
If NamesList(i, 2) <> vbNullString Then
'Get reference to sheet by old name, and handle if sheet is missing
Set ws = Nothing
On Error Resume Next
Set ws = targetWb.Worksheets(NamesList(i, 1))
On Error GoTo 0
' Rename sheet
If Not ws Is Nothing Then
On Error Resume Next
ws.Name = NamesList(i, 2)
On Error GoTo 0
If ws.Name <> NamesList(i, 2) Then
' Rename failed! What now?
End If
Else
'Sheet Missing! What now?
End If
End If
Next
End With
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.