I want to create a loop that copies one range to another, dependent on the value in a list. The list contains the names of all the ranges that I want to copy.
So in this example, PolicyOutput is a named range from DD15:DD77. I want it to update with values from another range, policy1, then loop to copy new values again from a different cell range, policy2.
The list of policies is in a range of cells called PolicyChoice
Each row of PolicyChoice contains a reference to a group of cells. It will be values: policy1, policy2, policy3 etc.
The values of the cells refer to named ranges. For example policy1 is A15:A77, and policy2 is B15:B77
I want A15:A77 to copy to DD15:DD77, then B15:B77 to copy to DD15:DD77, but in a way that can be updated and rerun as the list of "PolicyChoice" is changed by the user.
I tried the code below, but it just copies "policy1" over again into each cell in the range PolicyOutput, instead of the values in the range policy1
policyChoiceCount = (Sheets("RunModel").Range("policyChoice").Count) - Application.WorksheetFunction.CountIf(Sheets("RunModel").Range("policyChoice"), "")
For h = 1 To PolicyChoiceCount
Sheets(PolicySheetName).Range("PolicyOutput").Value = WorksheetFunction.Index(Sheets("RunModel").Range("policyChoice"), h)
Next h
Thanks!
Add Range(WorksheetFunction ..).value like this
Sheets(policySheetName).Range("PolicyOutput").Value = _
Range(WorksheetFunction.Index(Sheets("RunModel").Range("policyChoice"), h)).Value
or in simple steps
Sub mycopy()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Dim rngSource As Range, rngTarget As Range, cell As Range
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("RunModel")
Set wsTarget = wb.Sheets("PolicySheetName")
Set rngTarget = wsTarget.Range("PolicyOutput")
For Each cell In wsSource.Range("PolicyChoice")
If Len(cell) > 0 Then
On Error Resume Next
If IsEmpty(Range(cell)) Then
MsgBox "No named range " & cell, vbCritical, "ERROR"
Exit Sub
End If
On Error GoTo 0
rngTarget.Value = Range(cell).Value
End If
Next
End Sub
Related
I have been trying to Copy the Filtered data and pasting the data on filtered cell but my code is not working.
I have data in Range Sheet2.Range("O2:O10000") and i filtered this range to Sheet2.Range("O173:O2400").
I want to copy the data from filtered cells Sheet2.Range("O173:O2400") then paste this data to visible cells on same Sheet2.Range("N173:N2400")
Please note there are multiple hidden rows in this range.
Any help will be appreciated
Sub Copy_Paste__Visible_Cells_Only()
Sheet2.Range("O173:O2400").SpecialCells(xlCellTypeVisible).Copy
Sheet2.Range("N173:N2400").SpecialCells(xlCellTypeVisible).Paste
End Sub
In this case, pasting won't work. As far as I know, you can't change the paste behaviour to only paste to visible cells.
When you select visible cells only, you get a collection of areas (you can think of them as a discontinuous set of ranges). Given you're just trying to move your visible data to the left, you can do it by looping through the areas and assigning their values to the same area in the previous column. Something like this:
Public Sub CopyVisible()
Dim a As Range
For Each a In Sheet1.Range("O4:O17").SpecialCells(xlCellTypeVisible).Areas
a.Offset(0, -1).Value = a.Value
Next
End Sub
The .Offset(0,-1) is signalling that you wish the values to be moved one column to the left
You can see from this example, when I filter on "a" in column O and run the macro, only the "a" values are moved to column N.
I would use a generic sub copyVisibleCellsToOtherColumn to which you pass the source-range and the target-start range.
Advantage you can re-use it for different scenarios.
Sub test_CopyVisibleCells()
Dim rgSource As Range
Set rgSource = sheet2.Range("O173:O2400")
Dim rgTarget As Range
Set rgTarget = sheet2.Range("N173:02400")
copyVisibleCells rgSource, rgTarget
End Sub
'this ist the generic sub
Public Sub copyVisibleCellsToOtherColumn(rgSource As Range, rgTarget As Range)
Dim c As Range, a As Range
For Each a In rgSource.Areas
'this will return the visible cells within rgsource
For Each c In a.Cells
rgTarget.Rows(c.Row).Value = c.Value
Next
Next
End Sub
I found code from somewhere which able to copy visible cells and paste into visible cells. For easy usage, I manually assign a shortcut ctrl+shift+C to call the macro.
Public Sub Copy_Range_Paste_Into_Visible_Cells()
'Sub Copy_Range_Paste_Into_Visible_Cells()
Dim rngSource As Range, rngDestination As Range, cell As Range, cc As Long, i As Long
On Error Resume Next
Application.DisplayAlerts = False
Set rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
If rngSource Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
Set rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
If rngDestination Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
On Error GoTo 0
Application.DisplayAlerts = True
cc = rngSource.Columns.Count
For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
i = i + 1
Loop
rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
i = i + 1
Next
End Sub
I have two Excel workbooks.
First Workbook has two sheets: "Sales" and "Lookup".
Second Workbook has one sheet: "ID"
From the first workbook (Sales), I have to read column 'B' values, search it in column A of "Lookup" sheet and get name from column B.
After fetching ID, I have to write to column E of "ID" workbook.
I tried the first part, but it is not iterating through the cells of Sales and not picking value from "Lookup".
Sub btnExport_Click()
Dim rng As Range
Dim ws1, ws2 As Worksheet
Dim MyStringVar1 As String
Set ws1 = ThisWorkbook.Sheets("Lookup")
Set ws2 = ThisWorkbook.Sheets("Sales")
Set rng = ws2.Range("B2")
With ws2
On Error Resume Next 'add this because if value is not found, vlookup fails
MyStringVar1 = Application.WorksheetFunction.VLookup(Left(rng, 6), ws1.Range("A2:C65536").Value, 2, False)
On Error GoTo 0
If MyStringVar1 = "" Then MsgBox "Item not found" Else MsgBox MyStringVar1
End With
End Sub
*** Edited ***
Code fixed. It is now reading from first cell of Sales but not iterating. Also, while iterating and fetching from Lookup, it has to write to another workbook. This I am not able to fix.
There are two changes that you should make to start. First, try not to reference ActiveSheet (as mentioned in the comments). If the macro is run while a different sheet is selected, then it will mess things up. Store the appropriate worksheet in a variable, such as:
Dim ws As Worksheet
Set ws = Sheets("Sales")
The other item that stands out is in your loop, you are using the .Cells off of the rng object. In your case, you set rng to be the used range in Column B. Let's assume that's cells B2:B10. When you then say rng.Cells(i, 2), if actually offset to the second column of the range, which starts with Column B. You end up using column C.
Instead, try something like
Sub btnExport_Click()
Dim rng As Range
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("sales")
With ws
Set rng = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For i = 2 To rng.Rows.Count
.Cells(i, 2) = Application.WorksheetFunction.VLookup(.Cells(i, 1), Sheets("Lookup").Range("A:B"), 2, False)
MsgBox (.Cells(i, 2))
Next
End With
End Sub
I have a workbook, with multiple sheets, which have comments. I have to loop through each of the sheets and pick up the comments. I have implemented the following logic.
For Each Ip_Sheet In ActiveWorkbook.Worksheets
Set Rng = Ip_Sheet.Cells.SpecialCells(xlCellTypeComments)
If Rng Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In Rng
Comment_Author_NameAndComment = Split(cell.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
The above logic works fine if there are no merged cells in the worksheet. However, if there are merged cells/rows, the loop For Each cell In Rng runs for each of the cells in the merged cells range. For example, if columns A:D are merged, then the loop runs for each of the cells A, B, C and D and I get the same value in the AuthName and AuthComments variables.
My question is, how do I make the loop to skip to the next comment on the worksheet if I find a merged cell?
Edit:
I also tried to loop through all the comments in the sheet by the following method, however, the method was not successful - the Rng.Comment object was always empty.
For Each cmnt_obj In Rng.Comment
cmt_txt = cmnt_obj.Text
Next cmnt_obj
Since SpecialCells(xlCellTypeComments) returns all cells for a Merged Range, you need to detect when a cell is part of a named range and only process one of those cells. You can use Range.MergeCells to detect a merged cell, and Range.MergeArea to return the merged range itself. Then only report the comment if the cell is the Top Left cell of the merged range.
Something like this:
Sub Demo()
Dim rng As Range
Dim cl As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
If Not rng Is Nothing Then
For Each cl In rng.Cells
If cl.MergeCells Then
If cl.Address = cl.MergeArea.Cells(1).Address Then
ReportComment cl
End If
Else
ReportComment cl
End If
Next
End If
Next
End Sub
Sub ReportComment(cl As Range)
Dim Comment_Author_NameAndComment() As String
Dim AuthName As String
Dim AuthComments As String
Comment_Author_NameAndComment = Split(cl.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
Debug.Print AuthName, AuthComments
'...
End Sub
I need help to create an automatic method to copy a row to a specific sheet.
I have a Tab (Sales) with a WEB api query importing data in this sheet every 5 min. I have a row within the Sales sheet with a name range identifying each item. The row has 100 different names and there are 100 sheets created with same names within the workbook.
I want to copy the entire row for each item and copy it to the sheet with the same name of the item.
This is to fire off the copy sub:
'Copy Sales data Every 10 Min
Sub test()
'Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure…"
End Sub
I have seen many methods on how to copy the row automatically, but I need help in copy row and use the item name and paste to other sheet with same name.
Without further information here is an outline of what i described in the comments. Here the list of named ranges starts at cell J3 in NamesSheet. In the image, i have shown it in the same sheet (SourceSheet for simplicity). The list is read into an array and that array is looped to select the appropriate sheet to set the values in.
Rather than copy and paste it sets the target row (the next available row), in the sheet accessed by the array index, equal to the source row (copyRow). A With statement is used to avoid selecting the target sheet (more efficient).
No error handling added for missing sheets at present.
I haven't assumed there will be a list of 100 named ranges in the sheet, otherwise you could have sized the array from the start.
Named ranges in ColA of Sales tab:
List of named ranges in Names sheet (abbreviated)
Option Explicit
Private Sub myProc()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsNames As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Set wsNames = wb.Worksheets("Names")
Dim namesArr()
namesArr = wsNames.Range("J3:J" & wsNames.Cells(wsNames.Rows.Count, "J").End(xlUp).Row).Value
If UBound(namesArr, 1) <> wsSource.Range("ITEMName").Rows.Count Then
MsgBox "There are not a matching number of named ranges listed in Names sheet."
Exit Sub
End If
Dim i As Long
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
For i = LBound(namesArr, 1) To UBound(namesArr, 1)
With wb.Worksheets(namesArr(i, 1))
Set copyRow = wsSource.Range(namesArr(i, 1)).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Version 2:
Looping Named Ranges in Sales sheet (assumes only 101 Named Ranges in the sheet, tested with workbook scope, and that you will ignore 1 of these which is called ITEMName, no list required in a different sheet. Approach adapted from #user1274820.
Option Explicit
Private Sub myProc2()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following
Application.ScreenUpdating = False
Dim copyRow As Range
Dim nm As Variant
For Each nm In ThisWorkbook.Names
If nm.RefersToRange.Parent.Name = "Sales" And nm.Name <> "ITEMName" Then
With wb.Worksheets(nm.Name)
Set copyRow = wsSource.Range(nm.Name).EntireRow
If IsEmpty(.Range("A1")) Then 'First row in sheet is available
.Rows(1).Value = copyRow.Value2
Else
currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(currLastRow + 1).Value = copyRow.Value2
End If
End With
End If
Next nm
Application.ScreenUpdating = True
End Sub
I have a range of cell numbers that I need for multiple worksheet names.
I create multiple worksheets based on the number of rows.
Sub Copier()
Dim x As Integer
x = InputBox("Enter number of times to copy worksheet")
For numtimes = 1 To x
ActiveWorkbook.Sheets("OMRS 207").Copy _
After:=ActiveWorkbook.Sheets("OMRS 207")
Next
End Sub
That grabs only one name, OMRS 207.
I want to generate these worksheets using the entire range of cells in the original worksheet.
Try below code.
Dim data As Worksheet
Dim rng As Range
Set data = ThisWorkbook.Sheets("Sheet1")
Set rng = data.Range("A2")
Do While rng <> ""
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = rng.Value
Set rng = rng.Offset(1, 0)
Loop
I assumed that your data starts from 2nd row in Sheet1 and you want the sheet name as per values in Column A.
If you want row number as sheet name for newly added sheet just use rng.row while assigning name to sheet.