I'm trying to loop through all worksheets (except the first two), copying a value from each one, and then placing the copied value into a column. This is what I have so far. It isn't giving me an error message, but it's also not working.
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim grade As Double
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
grade = ws.Range("E11").Value
For Each rcell In rng.Cells
rcell.Value = grade
Next rcell
End If
Next ws
End Sub
I couldn't get the nested loops to work, but I was able to solve it using another method (looking for a match between the worksheet name and the values in a given column).
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Worksheets("Student List").Range("F2:F174")
For Each rcell In rng.Cells
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = rcell.Value Then
rcell.Offset(0, 3).Value = ws.Range("E11").Value
End If
Next ws
Next rcell
End Sub
I think this is how I would do it (surely not the only way):
Option Explicit
Sub copyGrades()
Dim ws As Excel.Worksheet
Dim grade As Double
Dim rng As Range
Dim count As Integer
count = 1
Set rng = ThisWorkbook.Worksheets("Student List").Range("H2:H174")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Rubric" And ws.Name <> "Student List" Then
grade = ws.Range("E11").Value
rng.Cells(count, 1) = grade
count = count + 1
End If
Next
End Sub
Related
Im trying to copy a table range with criteria, however I am not able to define the criteria to copy the desired lines, which consists of copying only the lines where the CC column has data skiping the entire row if CC is empty. I'll just copy ( copy to clipboard ), for paste I'll do it manually for other reasons
The lines will always be like this, never with a whole blank line between them like the second image
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For Each rng In .Range("B3:I3" & bottomA)
If WorksheetFunction.Sum(.Range("B" & rng.Row & ":I" & rng.Row)) > 0 Then
Range("B" & rng.Row & ":I" & rng.Row)).Copy
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Use Union to select a non-contiguous range.
Option Explicit
Sub CopyValues()
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, rngB As Range
Dim tbl As ListObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("CC2")
With ws.ListObjects("Tabela452")
For Each rngB In .ListColumns("CC").DataBodyRange
If Len(rngB) > 0 Then
If rng Is Nothing Then
Set rng = rngB.Resize(1, 8) ' B to I
Else
Set rng = Union(rng, rngB.Resize(1, 8))
End If
End If
Next
End With
If rng Is Nothing Then
MsgBox "Nothing selected", vbExclamation
Else
rng.Select
rng.Copy
MsgBox "range copied " & rng.Address, vbInformation
End If
End Sub
Please, test the next adapted code. It does not need any iteration:
Sub CopyValues()
Dim rngCopy As Range, tbl As ListObject
Dim srcWS As Worksheet: Set srcWS = Sheets("CC2")
Set tbl = srcWS.ListObjects(1) 'use here the table name, if more than 1
On Error Resume Next 'for the case of no any value in the table first column
Set rngCopy = tbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeConstants)
'or
'Set rngCopy = tbl.DataBodyRange.Columns(tbl.ListColumns("CC").Index).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngCopy Is Nothing Then 'for the case of no any values in table first column
Intersect(rngCopy.EntireRow, tbl.DataBodyRange).Copy
Else
MsgBox "No any value in column ""CC""..."
End If
End Sub
As I said in my comment, it works if the values in column "CC" are not result of formulas...
Copy Filtered Rows From Excel Table (ListObject)
The screenshot illustrates the benefits of using an Excel table:
The table can be anywhere on the worksheet.
You can easily reference a column by its name (header).
You can move the column anywhere in the table.
Sub CopyFilteredRows()
' Define constants.
Const WorksheetName As String = "CC2"
Const TableName As String = "Tabela452"
Const CriteriaColumnName As String = "CC"
Const Criteria As String = "<>" ' non-blanks ('blank' includes 'empty')
' Reference the objects ('wb', 'ws' , 'tbl', 'lc')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
Dim lc As ListColumn: Set lc = tbl.ListColumns(CriteriaColumnName)
' Reference the filtered rows ('rrg').
Dim rrg As Range
With tbl
If .ShowAutoFilter Then ' autofilter arrows are turned on
' Clear all filters.
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else ' autofilter arrows are turned off
.ShowAutoFilter = True ' turn on the autofilter arrows
End If
.Range.AutoFilter lc.Index, Criteria
' Attempt to reference the filtered rows ('rrg').
On Error Resume Next
' Reference the visible cells.
Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
' When columns are hidden, resize to entire rows of the table.
Set rrg = Intersect(.DataBodyRange, rrg.EntireRow)
On Error GoTo 0
' Clear the filter.
.AutoFilter.ShowAllData
End With
' Invalidate the filtered rows.
If rrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Copy.
rrg.Copy
End Sub
For the criteria when looking for empty values, you can always use LEN to check the number of characters in the cell.
If it is greater than 0 it means that something is in there, you can also set it to an exact amount of digits to be more precise.
Something like this should work:
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Dim currentRow As Long
Const ccColumn As Long = 2
Const startingRow As Long = 3
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For currentRow = startingRow To bottomA
If Len(.Cells(currentRow, ccColumn).Value) > 0 Then
.Range("B" & currentRow & ":I" & currentRow).Copy
End If
Next currentRow
End With
Application.ScreenUpdating = True
End Sub
I want to find the last non-empty cell in a given range. My solution does not work...
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim rGoalL As Range
Set wsRoadmap = Sheets("Roadmap")
Set rGoalL = wsRoadmap.Range("A12:A20").End(xlUp)
MsgBox rGoalL.Address
End Sub
If you want to find the cell most on the right in the rows covered by your range, try this:
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim rTarget As Range
Dim rGoalL As Range
Dim dColumn As Double
Set wsRoadmap = Sheets("Roadmap")
For Each rTarget In wsRoadmap.Range("A12:A20")
If dColumn < wsRoadmap.Cells(rTarget.Row, wsRoadmap.Columns.Count).End(xlToLeft).Column Then
Set rGoalL = wsRoadmap.Cells(rTarget.Row, wsRoadmap.Columns.Count).End(xlToLeft)
dColumn = rGoalL.Column
End If
Next
MsgBox rGoalL.Address
End Sub
Looping through the cells of the range, from the lowest row up and checking (For Each myCell In myRange(i).Cells) should be ok:
Function GetLastNonEmptyRow(myRange As Range) As Long
Dim i As Long
Dim firstCell As Long: firstCell = myRange.Cells(1, 1)
Dim myCell As Range
For i = firstCell + myRange.Rows.Count To firstCell Step -1
For Each myCell In myRange(i).Cells
If myCell <> "" Then
GetLastNonEmptyRow = myCell.Row
Exit Function
End If
Next myCell
Next i
GetLastNonEmptyRow = -1 'means that the whole range is non-empty
End Function
Called this way:
Sub TestMe()
Dim myRange As Range: Set myRange = Worksheets(1).Range("F8:G11")
Debug.Print GetLastNonEmptyRow(myRange)
End Sub
I'm finishing a script that verifies if a cell in Column A of Sheet1 ("INCIDENTS") is duplicated at Column A of Sheet2 ("INCDB") and if the cell is duplicate it deletes the whole row in Sheet1.
The problem is that after the first loop (and deleting the row) it gives me the 424 error and highlights If iSrc.Cells.Value = iDst.Cells.Value Then
Any ideas on the cause? Here's the code:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iSrc As Variant
Dim iDst As Variant
Dim rng As Range
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For Each iSrc In ws1.Range("A5:A9999" & LastRow)
For Each iDst In ws2.Range("A5:A9999")
If iSrc.Cells.Value = iDst.Cells.Value Then
If rng Is Nothing Then
Set rng = iSrc.EntireRow
Else
Set rng = Union(rng, iSrc.EntireRow)
End If
rng.EntireRow.Delete
End If
Next iDst
Next iSrc
End Sub
I'd do it without objects iSrc and iDst. And from reverse order - this code worked for me:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For i = 9 To 5 Step -1 'change 9 to 9999 for your real data
For j = 9 To 5 Step -1 'change 9 to 9999 for your real data
If Len(ws1.Cells(i, 1).Value) > 0 Then
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
ws1.Cells(i, 1).EntireRow.Delete
GoTo nextIteration
End If
End If
Next
nextIteration:
Next
End Sub
Regarding the performance issue of .EntireRow.Delete, this is the additional reading:
Tests on processing 1 million rows
Solution employing Sorting
I have a workbook with several sheets and I am trying to detect numbers in C9:C200 and copy them in a cell three columns over - for every sheet starting at the 7th. The code within the outermost forloop works fine on a single sheet but I get an error message when I try to loop it through the rest of the sheets. I think I have two problems:
I'm not sure how to bounce the c9:c200 range from sheet to sheet as it loops through the workbook
I think I need to tell VBA to reset the evaluations so that it starts from scratch on the next sheet.
Am I going in the right direction with this?
Thanks!
Sub MoveQtrLoop()
Dim CEL As Range
Dim RNG As Range
Dim I As Integer
Dim WrkSht As Worksheet
Dim WS_Count As Integer
I = 0
WS_Count = ActiveWorkbook.Worksheets.Count
For Each WrkSht In ActiveWorkbook.Worksheets
I = I + 1
If 6 < I < WS_Count Then
Set RNG = ActiveSheet.Range("c9:C200")
For Each CEL In RNG
If CEL.HasFormula = True Then
CEL.Offset(, 3) = CEL.Value
ElseIf IsNumeric(CEL) = True Then
CEL.Offset(, 3) = CEL.Value
Else
End If ****ERR. OCCURS HERE****
Next CEL
Else
End If
Next WrkSht
End Sub
When you declare your range you are doing it based on ActiveSheet but you are not activating the following sheets through each loop. But rather than using ActiveSheet just set the target range with your WrkSht variable:
Set RNG = WrkSht.Range("c9:C200")
Hope this resolves your issue.
It's not looping because you're using ActiveSheet's range. Change it to:
Dim CEL As Range
Dim RNG As Range
Dim I As Integer
Dim WrkSht As Worksheet
Dim WS_Count As Integer
I = 0
WS_Count = ActiveWorkbook.Worksheets.Count
For Each WrkSht In ActiveWorkbook.Worksheets
I = I + 1
If 6 < I < WS_Count Then
Set RNG = wrksht.Range("c9:C200")
For Each CEL In RNG
If CEL.HasFormula = True Then
CEL.Offset(, 3) = CEL.Value
ElseIf IsNumeric(CEL) = True Then
CEL.Offset(, 3) = CEL.Value
Else
End If
Next CEL
Else
End If
Next WrkSht
End Sub
I am trying to create a Macro that will look through all the worksheets in a workbook and find the column named "ID". There will be an "ID" column in most of the worksheets, but the header may not necessarily be in row 1. Once the column has been found I would like to copy all the data in that column to a new worksheet. When copying the data over to a new worksheet I would like the data to be copied all in column A in the new worksheet- so would like the data to be copied into the next blank cell. So far this is what I have got
Sub Test()
Dim ws As Worksheet
Dim sString As String
Dim sCell As Variant
Dim cfind As Range
Dim j As Integer
For Each ws In Worksheets
If ws.Name = "Archive" Then GoTo nextws
ws.Activate
j = ActiveSheet.Index
'MsgBox j
On Error Resume Next
Set cfind = Cells.Find(what:="ID", lookat:=xlWhole)
If Not cfind Is Nothing Then
cfind.EntireColumn.Copy
Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial
End If
nextws:
Next ws
End Sub
I cant seem to get the last bit right that pastes the data. At the moment it just pastes it in the next available column.
So, you want all in Column A, right?
Change to
With Worksheets("Archive")
If .Range("A1") = "" Then
.Range("A1").PasteSpecial
Else
.Range("A1").Offset(.UsedRange.Rows.Count).PasteSpecial
End If
End With
from
Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial
This will line up the ID headers on row 1:
Sub Test()
Const SHT_ARCHIVE As String = "Archive"
Dim ws As Worksheet
Dim cfind As Range, rngList As Range
Dim j As Integer
j = 0
For Each ws In Worksheets
If ws.Name <> SHT_ARCHIVE Then
j = j + 1
Set cfind = ws.UsedRange.Find(what:="ID", lookat:=xlWhole, LookIn:=xlValues)
If Not cfind Is Nothing Then
Set rngList = Range(cfind, ws.Cells(Rows.Count, cfind.Column).End(xlUp))
Worksheets(SHT_ARCHIVE).Cells(1, j).Resize(rngList.Rows.Count, 1).Value = rngList.Value
End If
End If
Next ws
End Sub