Loop through dropdown and copy-paste - excel

I'm trying to loop through all values in a dropdown list, the source for which is in sheet "Comm O & S", range A31:L31.
I want to copy values from another sheet that result from the selection in the dropdown and paste these values in a column in a separate sheet (starting at column C). Then, I want to select the next value in the dropdown and copy-paste the values in the next column over, etc.
I am having trouble with the copy-paste within the dropdown loop.
Sheets("Scenario by Payer").Activate
For Each rngCell In wb.Worksheets("Comm O & S").Range("A31:L31")
' Set the value of dd_comm
ws.Range("D14").Value = rngCell.Value
Sheets("Detailed Outputs").Select
Range("T52:t60").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Comm O & S").Activate
For Each c In ActiveSheet.Range("C7:L7").Cells
c.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next rngCell
Next c

Give this a try:
Sub tgr()
Dim wb As Workbook
Dim wsScen As Worksheet
Dim wsComm As Worksheet
Dim wsOuts As Worksheet
Dim rDDList As Range
Dim rDDCell As Range
Dim rDDValue As Range
Dim rCopy As Range
Dim rDest As Range
Set wb = ActiveWorkbook
Set wsScen = wb.Sheets("Scenario")
Set wsComm = wb.Sheets("Comm O & S")
Set wsOuts = wb.Sheets("Detailed Outputs")
Set rDDList = wsComm.Range("A31:L31")
Set rDDValue = wsScen.Range("D14")
Set rCopy = wsOuts.Range("T52:T60")
Set rDest = wsComm.Range("C7")
For Each rDDCell In rDDList.Cells
rDDValue.Value = rDDCell.Value
rDest.Resize(rCopy.Rows.Count, rCopy.Columns.Count).Value = rCopy.Value
Set rDest = rDest.Offset(, rCopy.Columns.Count)
Next rDDCell
End Sub

Related

how to replace text after autofilter has been applied

I can't figure it out how to replace the value of a range after apply autofilter
my code below
Dim ws1 As Worksheet
Dim myname As String
Dim LastRow As Double
Dim LastRow2 As Double
myname = "Inventory"
Set ws1 = Sheets(myname)
ws1.Activate
ws1.Cells(1, 1).Select
' Find the last row
LastRow = ws1.Range("A1").CurrentRegion.Rows.Count
'select the table we are gonna work with
ws1.Range("A1:Q" & LastRow).Select
'filter table
Selection.AutoFilter Field:=6, Criteria1:="Online"
'Find the last row
LastRow2 = ws1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
' I want to select only the visible rows from column H after auto filter
'h1 is header cell
ActiveSheet.Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy ' to remove formulas
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H1:H" &
LastRow).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeBlanks).Value ="My new
text here"
the above code errors out, it says cant find the cells
Any ideas how I can do it?
Fill Empty Cells of a Filtered Column
Sub Test()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Inventory")
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion ' has headers
Dim drg As Range
Set drg = trg.Resize(trg.Rows.Count - 1).Offset(1).Columns("H") ' no headers
trg.AutoFilter 6, "Online"
' Reference the visible cells of the single-column Data range (no headers),
' the Visible range.
Dim dvrg As Range
On Error Resume Next
Set dvrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If dvrg Is Nothing Then
MsgBox "No visible cells in column.", vbExclamation
Exit Sub
End If
' Convert to values.
Dim arg As Range
For Each arg In dvrg.Areas
arg.Value = arg.Value
Next arg
' Reference the empty cells of the Visible range, the Empty range.
Dim derg As Range
On Error Resume Next
Set derg = dvrg.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If derg Is Nothing Then
MsgBox "No empty cells in visible cells of column.", vbExclamation
Exit Sub
End If
derg.Value = "My new text here"
End Sub

Selected range of cells via VBA doesn't work

EDITED
I would like to ask you for help & revision of my VBA code as I am new to VBA.
I have pivot table with 3 columns. Via slicer I choose the items I want to add in new data table, each item must be added 3 times - therefore in the code I used loop 3 times.
The VBA works perfectly when 2 or more items are chosen.
However, when only single item is selected, the VBA crashes because the "selected copied range" does not have the same size as "pasted range" size. Basically, it selects all cells from column "F2:H2" until the end of spreadsheet.
Sub Copy()
Dim i
For i = 1 To 3
StartRange = "F2:H2"
EndRange = "F2:H2"
Set a = Range(StartRange, Range(StartRange).End(xlDown))
Set b = Range(EndRange, Range(EndRange).End(xlDown))
Union(a, b).Select
Selection.Copy
lastrow = ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row + 1
Cells(lastrow, "T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
How to modify the code, if only single item is selected, it will copy the cells in new data table as well?
I can provide a test file for reference.
Use .End(xlDown) from the header row.
Option Explicit
Sub Copy()
Dim ws As Worksheet, rng As Range
Dim i As Long, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
For i = 1 To 3
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).Row + 1
rng.Copy
ws.Cells(lastrow, "T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
or to copy single rows
Sub Copy2()
Const REPEAT = 3
Dim ws As Worksheet, rng As Range
Dim row As Range, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).row + 1
For Each row In rng.Rows
If Not row.Hidden Then
ws.Cells(lastrow, "T").Resize(REPEAT, row.Columns.Count).Value = row.Value
lastrow = lastrow + REPEAT
End If
Next
End Sub

Range Reference Excel VBA

Hi I working some VBA to copy cells to another worksheet in the same workbook. However I am running into an error. Here is the challenege:
Worksheet with data to be searched.
I am looping through cells in Column A and looking for the word Properties: If the words is found I want to copy and paste special(transpose) the values in the adjacent cells up to three rows down to another worksheet in the same workbook.
So for example if the word "Properties is found in cell A9 I need to copy the values in B10:B12 and paste special transpose to the next empty row on Metadata Worksheet.
I got it working to copy the cell Offset(1,1), however I am having difficult expanding the copy range. Please see code below. The commented out code works fine, but the line just below it is what i am trying but it wont work.
Private Sub Search_n_Copy()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Dim rngCopy As Range, aCell As Range, srchRng As Range
Dim strSearch As String
Dim QueryResults As Worksheet
Set QueryResults = ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
QueryResults.Name = "MetaData"
strSearch = "Properties"
Dim LastRow As Long
With QueryResults
QueryResults.Range("A1").Value = "SI_ID"
QueryResults.Range("B1").Value = "SI_NAME"
QueryResults.Range("C1").Value = "SI_WEBI_DOC_PROPERTIES"
End With
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set srchRng = .Range("A1:A" & LastRow)
For Each aCell In srchRng
If aCell.Value = "Properties" Then
''aCell.Offset(1, 1).Copy
.Range("aCell.Offset(1, 1):aCell.Offset(3,1)").Copy
QueryResults.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End If
Next aCell
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

need to remove empty rows from Excel table and then resize the table - using VBA

I wrote a macro (mostly by recording it) that copies data from a section on one sheet then calculates the end of my table on another sheet and pastes (paste special, being that the data I am pasting is a formula and I need to paste the values) the data to the end of my table, which on its own increases the size of my table.
That works.
My problem is that I am not sure how much of my original range of data (that I am copying) will actually have values in it (there is a formula that is either giving it a value or ""), so I take a large range, just in case
So.... after I pasted it I would like to go through my table and remove any rows that were added that only had empty strings ("") and no values, and then resize the table so it is only as large as the rows that have data.
These rows can be in the middle or at the end of my pasted data.
I need help on the VBA code to do that.
I may also need to clear the formatting that the table automatically added to those additional rows
here is the code I have until now
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Probably best to only place data into the table if its valid, rather than clean up after the paste.
Something like this
Sub Demo()
Dim rDest As Range
Dim lo As ListObject
Dim wsSrc As Worksheet
Dim rSrc As Variant
Dim i As Long
Dim rng As Range
'there are better ways to get a reference to the source data, but thats not the Q here
Set wsSrc = ActiveSheet
Set rSrc = wsSrc.Range("O7:R30")
' destination sheet
With Sheets("deposits")
'get reference to table
Set lo = .ListObjects("deposits")
'Get reference to first row after the table
Set rDest = lo.DataBodyRange.Rows(lo.DataBodyRange.Rows.Count + 1)
i = 0
'loop thru source data rows
For Each rng In rSrc.Rows
'if a row has data
If Application.WorksheetFunction.CountA(rng) > 0 Then
'copy values into table
rDest.Offset(i).Value = rng.Value
i = i + 1
End If
Next
End With
End Sub
This code worked, not elegant, but it worked
Sub copyToDeposits()
Dim theSheet As String
theSheet = ActiveSheet.Name
Application.ScreenUpdating = False
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim lo As ListObject
Dim lRow As ListRow
Dim rng As Range
Dim delRows As Collection
Set lo = ActiveSheet.ListObjects("deposits") 'change to your table name
On Error Resume Next
For Each lRow In lo.ListRows
Set rng = Nothing
Set rng = lRow.Range.Cells(1, 2)
If Not rng Is Nothing Then
If rng = "" Then
If delRows Is Nothing Then
Set delRows = New Collection
delRows.Add lRow
Else
delRows.Add lRow, Before:=1
End If
End If
End If
Next
On Error GoTo 0
If Not delRows Is Nothing Then
For Each lRow In delRows
lRow.Delete
Next
End If
Sheets(theSheet).Select
Application.ScreenUpdating = True
End Sub

excel - Macro - How to iterate over rows & a range of cells

i've got a question.
I've got the names of sheets in my workbook in a sheet named "Summary". I've got some stats in a sheet called "Stats". I wanna loop over the names in summary sheet, select each sheet, then copy the values from B2:M2 from "stats" page, transpose copy it to column D2 in the sheet selected from "Summary" sheet. Then I want to move to next sheet from the list of sheets from "Summary" page, copy B3:M3 & copy as transpose the D2 column in the selected sheet & so forth.
I've managed to get this bit of code for it. It's not compelte. I'm unable to figure out how to increment from B2:M2 to B3:M3 to B4:M4 & so on.
Please can someone help me. I've never written VB code before.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim row_counter As Long, col_counter As Long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
row_counter = 2
col_counter = 2
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
row_counter = row_counter + 1
col_counter = col_counter + 1
Next MyCell
End Sub
See below code (which is your code with the addition of offset).
Offset will let you increment from B2:M2 to B3:M3 asb so on.
I replaced your row and col variable with just x since you only move by row.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim x as long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
x = 0
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Offset(x, 0).Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
x = x + 1
Next MyCell
End Sub
Also you can try this:
Dim MyCell, MyRange as Range
Dim wb as Workbook
Dim ws, wsTemp, wsStat as Worksheet
Dim x as Long
Set wb = Thisworkbook
Set ws = wb.Sheets("Summary")
Set wsStat = wb.Sheets("Stats")
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & lrow)
End With
x = 0
For Each MyCell in MyRange
Set wsTemp = wb.Sheets(MyCell.Value)
wsStat.Range("B2:M2").Offset(x, 0).Copy
wsTemp.Range("D2").PasteSpecial xlPasteAll, , , True
x = x + 1
Set wsTemp = Nothing
Next MyCell
End Sub
Already Tested.
Hope it does what you want to achieve.

Resources