I currently have code for each sheet I want to move but I am wondering if there was a way to reduce this code.
This is what I currently use to move each sheet times 8 or so sheets:
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ONI" Then
Set RNG1 = ONI.Range("A1:AK1").EntireColumn
Set RNG2 = All.Range("A1:AK1").EntireColumn
RNG2.Value = RNG1.Value
End If
Next
This is the code I use when I want to move a single column from all sheets to a single sheet. I can't figure out how to modify it to include more columns.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "MainSheet" Then
Set RNG1 = ws.Range("A1:A700")
Set RNG2 = Sheets ("MainSheet") _
.Cells(Rows.Count,"A").End(xlUp).Offset(1)
RNG2.Value = RNG1.Value
End If
Next
So basically is it possible to modify this code to include multiple columns?
Kudos for going for the value transfer instead of copy/paste. You just need to resize your Rng2 to match the size of Rng1.
I also modified this to work with dynamic row counts. If you need to copy a static range for each sheet, you can get rid of the LR bits and hard code the range. You need to keep nLR as this determines the next available row on your main sheet.
Sub Test()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("MainSheet")
Dim ws As Worksheet, Rng1 As Range, Rng2 As Range
Dim LR As Long, nLR As Long '(LR = Last Row, nLR = New Last Row for Main Sheet)
For Each ws In Worksheets
If ws.Name <> ms.Name Then
'Determine Relavent Ranges (last rows)
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
nLR = ms.Range("A" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set the ranges
Set Rng1 = ws.Range("A1:L" & LR)
Set Rng2 = ms.Range("A" & nLR).Resize(Rng1.Rows.Count, Rng1.Columns.Count)
'Value Transfer
Rng2.Value = Rng1.Value
End If
Next ws
End Sub
Think you need a nested loop here, long time since i wrote vba so i give pseudo code, hope this help you on the way.
for each ws
dim rang as Range
for Each rnge In Range("A1:H1").Columns
do something
next
next
Related
I am looking for a code to get the name of the last added sheet to Excel.
I have tried this...
Sub test()
Dim lastAddedSheet As Worksheet
Dim oneSheet As Worksheet
With ThisWorkbook
Set lastAddedSheet = .Sheets(1)
For Each oneSheet In .Sheets
If Val(Mid(oneSheet.CodeName, 6)) > Val(Mid(lastAddedSheet.CodeName, 6)) Then
Set lastAddedSheet = oneSheet
End If
Next oneSheet
End With
MsgBox lastAddedSheet.Name & " was last added."
End Sub
But it does not really work.
You can't reliably know what sheet was last added, because a sheet can be inserted before or after any existing sheet in a workbook, see Sheets.Add documentation.
Unless you're the one adding it. In which case, all you need to do is capture the Worksheet object returned by the Add method:
Dim newSheet As Worksheet
Set newSheet = wb.Worksheets.Add
Debug.Print newSheet.Name
Extracting the digits from the CodeName isn't going to be reliable either - especially if you assume that every sheet's code name begins with 5 letters. On a German machine, the CodeName of what we see as Sheet1 would be Tabelle1 - but then again the role of that digit is strictly to ensure uniqueness of the names of the VBComponent items in the VBA project, and none of it says it has anything to do with any sort of ordering.
As per #MathieuGuindon his answer, I can't think of any "simple" way to safely return the name of the latest added sheet. However if you willing to sacrifice some designated space in your project to store CodeNames you could try to utilize the Workbook_NewSheet event.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim lr As Long
With Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(lr, 1) = ActiveSheet.CodeName
End With
End Sub
Obviously you need to optimize this to add names when adding sheets during runtime. In this simplified example I manually added the existing sheet "Blad1", and upon adding new sheets, the list grew.
When deleting you can utilize the SheetBeforeDelete event, like so:
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
Dim ws As Object
Dim lr As Long, x As Long
Dim rng1 As Range, rng2 As Range, cl As Range
With Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Set rng1 = .Range("A2:A" & lr)
For Each ws In ActiveWindow.SelectedSheets
For Each cl In rng1
If cl = ws.CodeName Then
If Not rng2 Is Nothing Then
Set rng2 = Union(rng2, cl)
Else
Set rng2 = cl
End If
End If
Next cl
Next ws
End With
If Not rng2 Is Nothing Then
rng2.Delete
End If
End Sub
Now to get the latest added sheet we can refer to the last cell in our designated range:
Sub LastAdded()
Dim lr As Long
With ThisWorkbook.Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Debug.Print "Last added sheet is codenamed: " & .Cells(lr, 1)
End With
End Sub
My take on it is that it would be safest to use the CodeName since they are least likely to get changed and are unique. We can also safely keep using our rng variable since there will always be at least one worksheet in your project (and that might just be the designated one if you protect it). Working in this project will now keep track of latest added worksheet.
Sheets could be a Chart or a Worksheet.
You could try use Worksheets instead of Sheets in your code.
sub test()
Dim lastAddedSheet As Worksheet
Dim oneSheet As Worksheet
With ThisWorkbook
Set lastAddedSheet = .WorkSheets(1)
For Each oneSheet In .WorkSheets
If Val(Mid(oneSheet.CodeName, 6)) > Val(Mid(lastAddedSheet.CodeName, 6)) Then
Set lastAddedSheet = oneSheet
End If
Next oneSheet
End With
MsgBox lastAddedSheet.Name & " was last added."
End Sub
Hi I'm looking to create code for copying certain columns (AH to AX) across all worksheets then skipping worksheets named "Aggregated" & "Collated Results"
I have this already
Sub FillSheets()
Dim ws As Worksheets
Dim worksheetsToSkip As Variant
Dim rng As Range
Dim sh As Sheet1
Set rng = sh.Range("AH1:AX7200")
worksheetsToSkip = Array("Aggregated", "Collated Results")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
End Sub
This will
Loop through sheets
"Copy" data from AH1 - AX1 down to the last used row that is determined by Column AH (Update column if needed)
"Paste" data on a sheet named Sheet1 (Update if needed). The data will be pasted in Column AH on the first available blank row. It's not clear what column you want to paste the data in. You just need to change AH to Some Column to modify
"Copy" and "Paste" are in quotes because we are really just transferring values here since this is quicker. We are actually setting the values of two equal sized ranges equal to each other.
Option Explicit
Sub AH_AX()
'Update "Sheet1" to sheet where data is being pasted
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1")
Dim ws As Worksheet, wsLR As Long, msLR As Long
Dim CopyRange As Range, PasteRange As Range
For Each ws In Worksheets
If ws.Name <> "Aggregated" And ws.Name <> "Collated Results" Then
'Determine last rows
wsLR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
msLR = ms.Range("AH" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set Ranges
Set CopyRange = ws.Range("AH1:AX" & LR)
Set PasteRange = ms.Range("AH" & msLR).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count)
'Value Transfer (Quicker than copy/paste)
PasteRange.Value = CopyRange.Value
End If
Next ws
End Sub
I've been trying to work through a problem for a sheet I'm working on but my limited vba knowledge has got me stuck.
What I currently have is code that copies over a reference number (column A) for a record to a new sheet if it has the value "CHK" in Column Y. This code is shown below.
The issue i'm having is trying to add some code that means when I run the macro only new entries that match the criteria will be copied over. At the moment when I run the macro it duplicates the entries that have already been copied (i.e. I run the macro once and get 1,2,3 I then run it again, adding another cell, and get 1,2,3,1,2,3,4.
I've been trying to come up with ideas and thought about using "If" to compare the final reference number in the sheet i copy to and the register sheet. And then setting up a similar process that would only copy values that were larger than the final reference number in the sheet i copy to. This would require me to set up the same process as below but limited to only values greater than the final value in the sheet i'm copying to.
This would require two macros i think, one to populate the list the first time (code that is below) and then one to run an update as discussed.
My question was will this process work or are there better ways that i am missing to achieve what I need to achieve.
Thanks all.
Sub Copy_detailed_WithNum_V4_Test()
'Create and set worksheet variables
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
'Create search range, cel and lastrow variable
Dim SrchRng As Range, cel As Range, Lastrow As Long
'Set the range to search as column Y in the detailed register (Y2 to last used cell in Y)
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
'Stop screen updating with each action
Application.ScreenUpdating = False
For Each cel In SrchRng
'Check if the VIPP Flag for the entry is CHK
If InStr(1, cel.Text, "CHK") Then
'If the entry is CHK, set the lastrow variable as first empty cell in row a of the VIPP Register
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
'Set the value of cells in Column A in VIPP Register to be equal to record number values for those entries that require a VIPP CHK
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
'Repeat for next cell in the search range
Next cel
Application.ScreenUpdating = True
End Sub
I believe this will do the trick.
You can run the macros seperately or add Call RemoveDuplicates before ending your first sub.
Sub RemoveDuplicates()
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim Unique As Range: Set Unique = ws2.Range("A2:A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row)
Dim MyCell As Range, DeleteMe As Range
For Each MyCell In Unique
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), MyCell) > 1 Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
This should check to see if your value exists before even pasting which means this one sub should be sufficient.
Sub Copy_detailed_WithNum_V4_Test()
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim SrchRng As Range, cel As Range, Lastrow As Long
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each cel In SrchRng
If InStr(1, cel.Text, "CHK") Then
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), cel.Offset(0, -24)) = 0 Then
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps