I'm looking to pull cells with certain text across multiple worksheets and put it into a new worksheet. I'm stuck on creating a loop, or just general code, that would let me use what I have across more than one worksheet.
Here's my code:
Sub EnzymeInteractions()
' Copy EPC cells Macro
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("Enzyme Interactions (110)").Range("I" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In Sheets("Enzyme Interactions (110)").Range("I:I" & bottomI)
If c.Value = "EPC" Then
c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
x = x + 1
End If
Next c
' CombineColumns Macro
Dim rng As Range
Dim iCol As Integer
Dim lastCell As Integer
Set rng = ActiveCell.CurrentRegion
lastCell = rng.Columns(1).Rows.Count + 1
For iCol = 2 To rng.Columns.Count
Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)).Cut
ActiveSheet.Paste Destination:=Cells(lastCell, 1)
lastCell = lastCell + rng.Columns(iCol).Rows.Count
Next iCol
' RemoveBlanks Macro
Cells.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("A9").Select
End Sub
Everything works perfectly aside from the fact I don't know how to use this marco across multiple worksheets (about 10).
You can add a parameter to your sub and pass in each worksheet to be processed as an argument.
sub Main()
EnzymeInteractions Sheets("Enzyme Interactions (110)")
EnzymeInteractions Sheets("Enzyme Interactions (120)")
'etc
End sub
Sub EnzymeInteractions(ws As Worksheet)
'use ws instead of (eg) Sheets("Enzyme Interactions (110)")
End Sub
You do need to fix the second half of your sub to remove the use of ActiveCell/ActiveSheet: you should always use explicit range/sheet references where you can.
See: How to avoid using Select in Excel VBA
for guidelines on that.
Related
I am new to VBA and I am trying to write some code to copy data from one worksheet to another one. I have checked various sites and tried to write the code, but until I always get an error. The setting is as follows:
I have various worksheets, most of them are worksheets based on different teams (I will call them Team-Worksheets), one sheet is the data I import from an external databank (I will call it Import-Worksheet).
The code should loop through all the Team-Worksheets and based on the Name of the Team, which is always located in Cell “A2” it should find all stories that belong to the team in the “Import-Worksheet”(comparing it with “Team Name Column”) and ONLY copy the “ID” located in the “ID Column” and paste it into the second row of “ID Column” of the ListObject 1 of the corresponding "Team-Worksheet". Then it should find the next ID of that Team in the “Import-Worksheet” and copy-paste it into the next row of ListObject 1(all sheets have multiple listobjects, with varying length and start points). After it went through all the rows it should continue with the next “Team-Worksheet”.
I am unsure if I should run a 1) "for-loop" + "for-loop" 2) “for-loop” + an “advanced-filter”, or 3) “for-loop” + “for-loop combined with index/match”?
I used if B4 = Epic Id Link as I don't want to apply this to all the worksheets
Example 1:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim x As Long
Dim y As Worksheet
Dim rw As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
i = sht.Range("A2")
Set y = ActiveSheet
If sht.Range("B4").Value = "EPIC ID Link" Then
Sheets("Jira Import").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 5 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 19).Value
If ThisValue = i Then
Cells(x, 4).Copy
y.ListObjects(1).ListColumns("US ID").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Jira Import").Select
End If
Next x
End If
Next sht
Application.ScreenUpdating = True
End Sub
Example 2:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim rgData As Range, rgCriteria As Range, rgOutput As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
Set i = ActiveSheet.Range("A2")
If sht.Range("B4").Value = "EPIC ID Link" Then
Set rgData = ThisWorkbook.Worksheets("Jira Import").Range("S5").CurrentRegion
Set rgCriteria = i
Set rgOutput = ActiveSheet.ListObjects(1).ListColumns("US ID").DataBodyRange
rgData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rgOutput, Unique:=True
End If
Next sht
Application.ScreenUpdating = True
End Sub
Solving this would save me plenty of manual work!
This code copies the entries from Sheet1!A2, Sheet1!B2, etc. and pastes them onto Sheet2 with 3 rows between each entry. I want to duplicate this code without using .select.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Sheets("Sheet1").Select
Range("A2,B2,C2,D2,E2").Select
ActiveCell.Range(Cells(i, 1), Cells(i, 2)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(((i - 1) * 4) + 1, 1).Select
ActiveSheet.Paste
Next i
End Sub
This is what I have so far, but it is not working.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Dim ws1 As Worksheet, rng As Range, act As Range
Set ws1 = Worksheets("Data")
Set rng = ActiveSheet.Range("A2,B2,C2,D2,E2")
Set act = ActiveCell.Range(Cells(i, 1), Cells(i, 2))
Selection.Copy
Dim ws2 As Worksheet, rng2 As Range
Set ws2 = Worksheets("Calculate")
Set rng2 = Cells(((i - 1) * 4) + 1, 1)
ActiveSheet.Paste
Next i
End Sub
I used this type of operation in one of my vba codes:
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
So you can edit that to your situation.
you could use Offset() property of Range object
Sub Copy_Paste()
Dim i As Long
For i = 1 To 100
Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Copy Destination:=Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4)
Next
End Sub
while if you only need paste values, then it's quicker:
Sub Copy_Paste_Values()
Dim i As Long
For i = 1 To 100
Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4).Value = Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Value
Next
End Sub
You know you can just say something like "Range x values = Range y values":
ws2.Range("A1:B4").Value = ws1.Range("A1:B4").Value
If you can define your ranges using Range(Cells(1,1), Cells(4,2)) then I'm pretty sure you can do everything you want in one line
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
I would like to copy a range and paste it into another spreadsheet. The following code below gets the copies, but does not paste:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).Activate
Ticker.PasteSpecial xlPasteAll
End Sub
How can I paste the copies into another sheet?
To literally fix your example you would use this:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).PasteSpecial xlPasteAll
End Sub
To Make slight improvments on it would be to get rid of the Select and Activates:
Sub Normalize()
With Sheets("Sheet1")
.Range(.Cells(2, 1), .Cells(65, 1)).Copy Sheets("Sheet2").Cells(1, 1)
End With
End Sub
but using the clipboard takes time and resources so the best way would be to avoid a copy and paste and just set the values equal to what you want.
Sub Normalize()
Dim CopyFrom As Range
Set CopyFrom = Sheets("Sheet1").Range("A2", [A65])
Sheets("Sheet2").Range("A1").Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value
End Sub
To define the CopyFrom you can use anything you want to define the range, You could use Range("A2:A65"), Range("A2",[A65]), Range("A2", "A65") all would be valid entries. also if the A2:A65 Will never change the code could be further simplified to:
Sub Normalize()
Sheets("Sheet2").Range("A1:A65").Value = Sheets("Sheet1").Range("A2:A66").Value
End Sub
I added the Copy from range, and the Resize property to make it slightly more dynamic in case you had other ranges you wanted to use in the future.
I would try
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Worksheets("Sheet2").Range("A1").Offset(0,0).Cells.Select
Worksheets("Sheet2").paste
This is what I came up to when trying to copy-paste excel ranges with it's sizes and cell groups. It might be a little too specific for my problem but...:
'**
'Copies a table from one place to another
'TargetRange: where to put the new LayoutTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Sub CopyLayout(TargetRange As Range, typee As Integer)
Application.ScreenUpdating = False
Dim ncolumn As Integer
Dim nrow As Integer
SheetLayout.Activate
If (typee = 1) Then 'is installation
Range("installationlayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
ElseIf (typee = 2) Then 'is package
Range("PackageLayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
End If
Sheet2.Select 'SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
If typee = 1 Then
nrow = SheetLayout.Range("installationlayout").Rows.Count
ncolumn = SheetLayout.Range("installationlayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("installationlayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
ElseIf typee = 2 Then
nrow = SheetLayout.Range("PackageLayout").Rows.Count
ncolumn = SheetLayout.Range("PackageLayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("PackageLayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
End If
Range("A1").Select 'Deselect the created table
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
'**
'Receives the Pasted Table Range and rearranjes it's properties
'accordingly to the original CopiedTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Function RowHeightCorrector(CopiedTable As Range, PastedTable As Range, typee As Integer, RowCount As Integer, ColumnCount As Integer)
Dim R As Long, C As Long
For R = 1 To RowCount
PastedTable.Rows(R).RowHeight = CopiedTable.CurrentRegion.Rows(R).RowHeight
If R >= 2 And R < RowCount Then
PastedTable.Rows(R).Group 'Main group of the table
End If
If R = 2 Then
PastedTable.Rows(R).Group 'both type of tables have a grouped section at relative position "2" of Rows
ElseIf (R = 4 And typee = 1) Then
PastedTable.Rows(R).Group 'If it is an installation materials table, it has two grouped sections...
End If
Next R
For C = 1 To ColumnCount
PastedTable.Columns(C).ColumnWidth = CopiedTable.CurrentRegion.Columns(C).ColumnWidth
Next C
End Function
Sub test ()
Call CopyLayout(Sheet2.Range("A18"), 2)
end sub
You can do something like below to paste values in other ranges. (faster than copying and pasting values)
ThisWorkbook.WorkSheets("Sheet2").Range("A1:A2").Value = Sheets`("Sheet1").Range("A1:A2").Value
Actually what i want to do , i have following data With Auto Filtering ,
-> I want to create new sheet for each unique Name selected from filtering .i.e. if John and Alex are selected then 2 new sheets should be created one for John and second for Alex , and each of them show own data (Name + No + R). When Next time if master sheet get updated then news data should be appended when i run macro. i'm using following code but its not working 100%.
Sub mycar()
x = 2
Do While Cells(x, 1) <> ""
If Cells(x, 1) = "John" Then
Worksheets("Sheet1").Rows(x).Copy
Worksheets("Sheet2").Activate
eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow)
End If
Worksheets("Sheet1").Activate
x = x + 1
Loop
End Sub
-> Here it copy only single data Written in the quotes.
-> Second time if i run this code , it is appending same data again with new data.
Help me to avoid this mistakes.
Thank you.
As discussed there is other possibility to set filter parameters in Array in procedure. The code would look like this one:
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Dim myArr As Variant
myArr = Array("John", "max")
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
Substitute Worksheets("Sheet1").Rows(x).Copy by Worksheets("Sheet1").Rows(x).EntireRow.Copy
And clear the destination worksheet before adding information.
I do quite similar exercise quite often. Therefore I provide full possible solution with some comments inside the code. It works for all unique values in column A and creates (if not exists) sheet with appropriate name equals to filter parameters.
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
'get unique values based on Excel features
'i guess some will not like it but I do :)
Range("a1").AutoFilter
Range("A1").CurrentRegion.Columns(1).Copy Range("ww1")
Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'be sure that range where you copy (like ww1) is empty range around
Dim myArr As Variant
myArr = Range(Range("ww2"), Range("ww2").End(xlDown))
Range("ww1").CurrentRegion.ClearContents 'some cleaning
Range("a1").AutoFilter '
Dim i As Long
For i = 1 To UBound(myArr, 1)
ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _
Operator:=xlAnd
On Error Resume Next
'this is for two reason- to check if appropriate sheet exists, if so to clean top area
'if you need to append you would comment this line
Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
'if you need to append only you would need to set range-to-copy a bit different
Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i, 1)
Err.Clear
End If
Next i
End Sub
This could not fully meet your requirements but could be a complete solution to improve accordingly.
Heading ##Below code is as per your requirement. Modify it based upon your requirement.
Private Sub Worksheet_Calculate()
Dim x As Integer
Dim rnge As Integer
x = Range(Selection, Selection.End(xlDown)).Count
rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
If Range("E1").Value > rnge Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Paste
End If
End Sub