I am trying to copy the range from one worksheet and paste it into another workbook and then do the same for another range in a different workbook. The issue I am having is it is taking what seems to be taking the range from the "most recently opened" workbook rather than selecting the correct one.
See below the following code:
Sub CopyTEST()
Dim Wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wB As Workbook
Dim rngToCopy1 As Range, rngToCopy2 As Range
Dim wbName1 As String, wbName2 As String
wbName1 = "Book"
wbName2 = "APP"
For Each wB In Application.Workbooks
If wB.Name Like wbName2 & "*" Then
Set Wb1 = wB
Debug.Print Wb1.Name
End If
If wB.Name Like wbName1 & "*" Then
With wB.Sheets("Sheet1")
If Left(Right(Cells(6, 4), 4), 2) = "12" Then
MsgBox ("12")
Set wb2 = wB
ElseIf Left(Right(Cells(6, 4), 4), 2) = "10" Then
MsgBox ("10")
Set wb3 = wB
Set wb3 = wB
Else
MsgBox ("ERROR")
Exit Sub
End If
End With
End If
Next wB
With wb2.Sheets("Sheet1")
Set rngToCopy1 = .Range("A1:II82")
End With
With wb3.Sheets("Sheet1")
Set rngToCopy2 = .Range("A1:II82")
End With
With Wb1
.Sheets("A").Range("A1:II82").Value = rngToCopy2.Value
.Sheets("B").Range("A1:II82").Value = rngToCopy1.Value
End With
End Sub
The issue I am seeming to have is say we have Book3 where the cells are equal to 12 and then Book4 where the cells are equal to 10. If Book4 is directly open then when we are going through the For loop with each wB, and we are observing Book3, it will take the range from Book4 instead of Book3...
The If statements obvserving the cells in the worksheets are showing correct values when I step into the code, they are just selecting the wrong ranges...
I hope this makes sense... Thanks!
You are not carrying the parent reference you created on to the cells.
With wB.Sheets("Sheet1")
If .Cells(6, 4) = "12" Then
MsgBox ("12")
Set wb2 = wB
ElseIf .Cells(6, 4) = "10" Then
MsgBox ("10")
Set wb3 = wB
Else
MsgBox ("ERROR")
Exit Sub
End If
End With
Note .Cells not Cells. This transfers the workbook/worksheet from the With ... End With to .Cells.
Related
This question is vaguely similar to renaming multiple worksheets from list using VBA, but is too different to get the answer from that question.
I will regularly need to rename dozens of worksheets in various incoming workbooks.
I wish to rename all worksheets by first copying all the worksheet names into a secondWorkbook.sheets(1) colA, manually creating new names in ColB, and then run a second macro to update the names in the originalWorkbook.
I am stuck on the second macro, but will provide both macros below. If anyone has a shorter/better way of writing these macros, I am all eyes.
First macro - copy all worksheet names into a new workbook.sheet(1).colA. This works, and creates a new unsaved workbook with the tab names in 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
Here is the macro I am stuck on. Both workbooks are open on screen, and I don't mind editing the macro to provide the workbook names. Unsure how to reference an unsaved workbook with a name like "Book4 - Microsoft Excel", so I have been saving it as Temp.xlsx and referencing it as namesWb. The workbook with the tabs to be renamed is referenced as 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
I realize that I could again loop through the targetWb and, for each tabname, find the location of that tabname in ColA() and rename it with the same position name from tabB() - but I am wondering if there is a faster/better way to do this.
You can loop through active workbooks like this:
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
Edit: Since you only have two open workbooks, you can shorten that:
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
I've refactored both your Sub's to show a more robust method.
Dim all variables, with explicit types (some of yours were defaulting to Variant)
Record the Workbook being processed in the top of the Names list
Still processes the ActiveWorkbook
Save the Temp workbook into the same folder as ActiveWorkbook
Rename... now skips any missing new names
Detect missing OldNames (see comment in code, place any response you want there)
Detect failed Renames (eg could be invalid characters in the new names)
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
I am using VBA to try to see if values in cells from one workbook match the named ranges from another workbook and if they do match then copy paste values from another column in those named ranges. I know they will match. the purpose is just to copy the values over into their designated named range.
The problem is in this line:
If rng = ws2.Range("NamedRange") Then
Here is my code below:
Sub Button4_Click()
Dim strFileName As String
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim wb2 As Workbook
Dim ws2 As Worksheet
Dim cell As Range
Dim rng As Range
Dim RangeName As String
Dim CellName As String
''Set wb2 = ActiveWorkbook
''Set ws2 = wb2.Sheet("Output")
''ws2.Range("D1:D12").Copy
''Set wb1 = ActiveWorkbook
strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "\BAC GVP - Template_Update_121917.xlsm"
If Dir(strFileName) <> vbNullString Then
Set wb1 = Workbooks.Open(strFileName)
Else
MsgBox "Sorry, the file does not exist on your Desktop at this time, please drop a copy to your Desktop from server!"
End If
''Set wb2 = ThisWorkbook
''Set ws2 = wb2.Sheets("Output")
''Set ws1 = wb1.Sheets("RVP Local GAAP")
''ws2.Range("D4:D12").Copy
''ws1.Range("G13:G21").PasteSpecial xlPasteValues
''RangeName = "myData"
''CellName = "G11:G83"
''Set cell = Worksheets("RVP Local GAAP").Range(CellName)
''ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
''RangeName = "NamedRange"
''CellName = "C4:C12"
Set wb2 = ThisWorkbook
Set ws2 = wb2.Sheets("Output")
Set ws1 = wb1.Sheets("RVP Local GAAP")
For Each rng In ws1.Range("CurrentTaxPerLocalGAAPProvision")
If rng = ws2.Range("NamedRange") Then
ws2.Range("ReportBalance").Copy
ws1.Range("CurrentTaxPerLocalGAAPProvision").PasteSpecial xlPasteValues
MsgBox "Values Copied Successfully"
End If
Next rng
MsgBox "Both Ranges do not have the same data"
End Sub
See image below - Cell G29 is called "GVP_Donations_CurrentTaxPerLocalGAAPProvision"... so for this example I would want $4,313 to appear in the cell G29
CurrentTaxPerLocalGAAPProvision:
Range ("NameRange"):
Your line saying
If rng = ws2.Range("NamedRange") Then
is crashing out due to the attempt to compare the value of rng (e.g. "" when rng is referring to the cell G29) with an array of values (the values in "NamedRange"). VBA cannot handle the comparison of a scalar to a vector. But it isn't what you are wanting to do anyway.
I believe that, to do what it seems you are trying to do, you can replace your loop with:
'Loop through all the values in NamedRange
For Each rng In ws2.Range("NamedRange")
'Transfer the value from the next column to the appropriate range in the
'destination sheet
ws1.Range(rng.Value).Value = rng.Offset(0, 1).Value
Next
MsgBox "Values Copied Successfully"
If only some of the values in "NamedRange" should be copied, then you may need to include a bit of testing to see whether the ranges are in the correct target area:
Dim dstRng As Range
'Loop through all the values in NamedRange
For Each rng In ws2.Range("NamedRange")
Set dstRng = Nothing
On Error Resume Next
Set dstRng = ws1.Range(rng.Value)
On Error GoTo 0
'Check that the range exists in destination sheet
If Not dstRng Is Nothing Then
'Check that the range exists in the appropriate area
If Not Intersect(dstRng, ws1.Range("CurrentTaxPerLocalGAAPProvision")) Is Nothing Then
'Transfer the value from the next column to the appropriate range in the
'destination sheet
dstRng.Value = rng.Offset(0, 1).Value
End If
End If
Next
MsgBox "Values Copied Successfully"
I want to search a particular Worksheet(Say "FebData") in all opened workbooks provided name of all workbooks totally depends on the user(it can be anything).To be honest by googling and putting some efforts form my side as well i got this code.
Dim wbSearch As Workbook, wsSearch As Worksheet, wsFind As Worksheet
Dim name As String
Dim j As String
name = InputBox("Enter your Sheet Name, You are searching for.")
If Len(name) = 0 Then 'Checking if Length of name is 0 characters
MsgBox "Please enter a valid name!", vbCritical
Else
j = name
End If
' to search a worksheet in all opened worksheets
For Each wbSearch In Application.Workbooks
For Each wsSearch In ActiveWorkbook.Sheets
if wsFInd = j then
worksheet("j").activate
else
Next wsSearch
Next wbSearch
end if
At last i want to add a feature which i don't have any idea about how to write a code for that, is if two worksheets of same name(Input from user) are present just pop up a msgbox "Duplicate sheet found".
This will loop through the workbooks and then loop through each sheet
Sub LoopBks()
Dim wb As Workbook, sh As Worksheet
For Each wb In Application.Workbooks
If wb.Name <> ActiveWorkbook.Name Then
For Each sh In wb.Sheets
If sh.Name = "FebData" Then
MsgBox "Sheets found in..." & wb.Name
End If
Next sh
End If
Next wb
End Sub
i have been assigned to use the .match function in vba, to compare 2 different columns in 2 different workbooks.
here is my code so far.. how do i use the match function to my goal ?
Sub Ob_match()
Dim swb As Workbook, dwb As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim oCell As Range, oMatch As Range
Set swb = ActiveWorkbook
Set sws = swb.Sheets("Item")
Set dwb = Workbooks.Open(swb.Path & "\EPC_EndItem.xlsm", ReadOnly:=True)
Set dws = dwb.Sheets("Data")
If Not oMatch Is Nothing Then
oCell.Offset(0, 1) = "Y"
Else
oCell.Offset(0, 1) = ""
End If
Next oCell
MsgBox "Processing completed"
End Sub
To run this code you should be on your your first workbook and second work-book should be open in background, I find this as an easier method than to call workbook using it's address, you may change that if you like
Sub vl()
Dim lastrow As Long
Sheets("Items").Select
lastrow = Range("B" & Rows.Count).End(xlUp).Row
Range("C2:C" & lastrow).Formula = "=IF(VLOOKUP(RC2,[Book2]Data!C4,1,FALSE), ""OK"","""")"
End Sub
Here I assumed that Name of your second book is Book2.
Change it to whatever it is in the code.
Hope this helps :)
I cant seem to get the code to loop to the next workbook open. After that I would like to consolidate all the single worksheets in each workbook into a single workbook and rename each tab based on it's workbook name.
I am not too far but sentence one is my first task
Sub cullworkbooksandCONSOLIDATE()
Dim ws As Worksheet
Dim wb As Workbook
Dim wsNAME As String
For Each wb In Application.Workbooks
With wb
For Each ws In ActiveWorkbook.Worksheets
With ws
wsNAME = ws.Name
If wsNAME <> "summary details" Then
ws.Delete
End If
End With
Next
End With
Next
End Sub
thank you kindly
Or more directly, just copy the sheet if it exists, rather than deleting all the non matches (which will also cause an error if the code deletes all sheets)
Sub cullworkbooksandCONSOLIDATE()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet
Dim wsNAME As String
Set wb1 = Workbooks.Add(1)
wsNAME = "summary details"
For Each wb In Application.Workbooks
With wb
If .Name <> wb1.Name Then 'if it's not the export workbook
On Error Resume Next
Set ws = wb.Sheets(wsNAME)
On Error GoTo 0
If Not ws Is Nothing Then ws.Copy Before:=wb1.Sheets(1)
End If
End With
Next
End Sub
This is so not going into my resumé.
Sub cullworkbooksandCONSOLIDATE()
Dim ws As Worksheet
Dim wb As Workbook
Dim wsNAME As String
Dim wbex As Workbook
'You'll need to define wbex, this is where your worksheets will be inserted
For Each wb In Application.Workbooks
With wb
If .Name <> wbex.Name Then 'if it's not the export workbook
For Each ws In wb.Worksheets 'not necessarily active workbook
With ws
wsNAME = LCase(.Name)
If wsNAME <> "summary details" Then
.Delete 'why do you need to delete it?
Else
.Name = wb.Name
.Copy Before:=wbex.Sheets(1)
End If
End With
Next
.Close SaveChanges:=False 'you really don't want to corrupt your source data, do you?
End If
End With
Next
End Sub