how would I loop through visible rows in a filtered list? I have a cell in the first filtered row in let's say column B that is a "Y". I need to be able to change all non-hidden cells in a specific column to be Y. This needs to be dynamic too because the column B range is going to be different everyday.
Essentially, I Need to modify this code:
Range("B2").Select --Where B2 is "Y"
Selection.AutoFill Destination:=Range(*This is where I am unsure*)
Not sure what exactly you are trying to achieve here with Autofill, but this will give you an idea about how to deal with filtered cells...
Dim ws As Worksheet
Dim lr As Long
Dim FillWith As String
Set ws = ActiveSheet 'Change it as per your requirement
lr = ws.UsedRange.Rows.Count
FillWith = ws.Range("B2").Value 'Change it as per your requirement
If ws.FilterMode Then
If ws.Range("B1:B" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
ws.Range("B2:B" & lr).SpecialCells(xlCellTypeVisible).Value = FillWith
End If
End If
You can refer to visible cells only using SpecialCells
Range("A2:A100").SpecialCells (xlCellTypeVisible)
Related
Background: This is my first time dealing with macros. I will have two worksheets that I’ll be using. The first sheet, ‘Source’ will have data available. The second sheet, ‘Final’ will be blank and is going to be where the macro will be pasting the data I’d like it to collect from the ‘Source’ sheet.
* I want the macro to find the specified header in the ‘Source’ sheet, copy that cell containing the header all the way down to the last row of existing data (instead of the entire column), and paste it onto the ‘Final’ sheet in a specified column (A, B, C, etc.). *
The reason why I have to specify which headers to find is because the headers in the ‘Source’ sheet won’t always be in the same position, but the ‘Final’ sheet’s headers will always be in the same position – so I CAN’T just record macros copying column A in ‘Source’ sheet and pasting in column A in ‘Final’ sheet. Also, one day the ‘Source’ sheet may have 170 rows of data, and another day it may have 180 rows.
Although, it would probably be best to copy the entire column since one of the columns will have a few empty cells rather than to the last row of existing data. I’m assuming it would stop copying when it reaches the first empty cell in the column chosen which would leave out the remaining data after that empty cell in the column – correct me if I’m wrong. If copying the entire column is the best way, then, please provide that as part of the possible solution. I’ve attached an example of the before & after result I would like accomplished:
Example of Result
Find Header=X, copy entire column -> Paste into A1 in ‘Final’ sheet
Find Header=Y, copy entire column -> Paste into B1 in ‘Final’ sheet
Etc..
I’m sorry if my wording isn’t accurate – I tried to explain the best I could. It’d be awesome if someone could help me out on this! Thanks!
u can try with this. i think its clear and step-by-step. it can be very optimized, but to start with vba i think its better this way.
the name of the column must be the same in both sheets.
Sub teste()
Dim val
searchText = "TEXT TO SEARCH"
Sheets("sheet1").Select ' origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns
For i = 1 To x 'iterate trough origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet2").Select ' destination sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count ' get number of columns
For j = 1 To y 'iterate trough destination columns
If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If
Next j
End If
Next i
End Sub
good luck
I modified an answer I gave to another user with similar problem for your case,
I use dictionary function in most of my data sheets so that I can shift columns around without breaking the code, the below code you can shift your columns around and it will still work
the only main restriction is
1. your header names must be unique
2. your header name of interest must be exactly the same.
i.e. your source header of interest is PETER then your Data table should have a header with PETER and it must be unique.
Sub RetrieveData()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1 'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub
I need help placing a formula in row 51 from column A to AE on sheet "COPY". The formula is "Trim(A1)" and needs to be dragged until "Trim(AE1)" while still being in row 51 (A51:AE51)
This is what I have so far, but its pulling up an error on "lascolumn = range..."
Sub INSERT_TRIM_COPY()
Sheets("COPY").Select
Dim Lastcolumn As Long
Lastcolumn = Range("A:AE" & Columns.Count).End(xlToRight).Column
Range("A51:AE51" & Lastcolumn).FORMULA = "=TRIM(A1)"
End Sub
You need to use: Range(Cells(51,1), Cells(51,Lastcolumn).Formula = "=Trim(A1) Because your lastcolumn is variable is numeric you need to use the cells function in the range. The first number is for row number and the second is for the column.
I believe the following will do what you expect it to, the code you used to get the Last Column wasn't right:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("COPY")
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'get the last Column on Row 1 with data
ws.Range(ws.Cells(51, 1), ws.Cells(51, LastCol)).Formula = "=Trim(A1)"
'add formula from column A to the last Column
End Sub
how to copy & paste the data from one column to another between two sheets of excel workbook ... without overwriting the destination column content?
I am using below code to copy & paste but every time I run it it is overwriting the existed content. I want to be pasted from next row of the column.
Sub DirectCopySample()
Application.ScreenUpdating = False
Sheets("Updating Sheet").Range("A:A").Copy Destination:=Sheets("Sheet1").Range("G:G")
Sheets("Updating Sheet").Range("B:B").Copy Destination:=Sheets("Sheet1").Range("F:F")
Sheets("Updating Sheet").Range("C:C").Copy Destination:=Sheets("Sheet1").Range("B:B")
Application.ScreenUpdating = True
End Sub
Don't copy the entire column. Copy a specific 1-cell-wide range of X rows (where X is your data) and define all your variables based on the current size of the data. For instance if you want to copy column A from sheet1 to the end of column B in sheet2.
Sub CopyColumn()
Dim wsCopy As Worksheet
Set wsCopy = Sheets("<Sheet Name>")
Dim wsPaste As Worksheet
Set wsPaste = sheets("<Sheet Name>")
'/ Much better to make your worksheets variables and then reference those
Dim lngFirstRow As Long
Dim lngFinalRow As Long
Dim lngCopyColumn As Long
Dim lngPasteColumn As Long
Dim rngCopy As Range
Dim rngPasteCell As Range
lngCopyColumn = 1 '/ ("A" Column)
lngDestinationColumn = 2 '/ ("B" Column)
wsCopy.Activate
lngFirstRow = 1
lngFinalRow = Cells(1048576, lngCopyColumn).End(xlUp).Row
'/ Starts at the bottom of the sheet, stops at the first cell with data in it, returns that cell's row
Set rngCopy = Range(Cells(lngFirstRow, lngCopyColumn), Cells(lngFinalRow, lngCopyColumn))
'/ Defines the range between those 2 cells
rngCopy.copy
wsPaste.Activate
lngFinalRow = Cells(1048576, lngPasteColumn).End(xlUp).Row
Set rngpaste = Cells(lngFinalRow + 1, lngPasteColumn)
'/ Pastes to the row 1 cell below the last filed cell in Column B
rngpaste.Paste
End Sub
#Grade 'Eh' Bacon outlined the correct process in his or her comment.
The crux of the issue is finding the size of the ranges you are copying from and pasting to. My current favorite method of doing so is the code snippet below:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
That will find the last non-empty row in your worksheet. So if for some reason column A has 100 rows, B has 200 rows, and C has 300 rows it will return 300 as the last row.
On the paste side of things, you could use the same method and add 1 to it so you paste into the first empty row, but if the columns have different numbers of rows you will end up with many blank rows in the shorter columns before your data is pasted at the bottom.
A work around this is the following code:
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
This will start at the bottom of column G and head up until it hits a row with data in it and then add 1 so that you are pasting into the first blank row of the column. You could then create variables for columns H and I that do the same thing.
Putting it all together your code would look something like this in the end:
copyLastrow = Sheets("Updating Sheet").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
pasteLastrowG = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row + 1
'pasteLastrowH ...
'pasteLastrowI ...
Sheets("Updating Sheet").Range("A2:A" & copyLastrow).Copy Destination:=Sheets("Sheet1").Range("G" & pasteLastrowG)
'Copy and paste B code here
'Copy and paste C code here
I have 2 Master Sheets based on 2 conditions of location. I import this data from an Excel Workbook into a worksheet on the Master Sheet Workbook. I think it would be better if I was able to scan the first column (A for example) and if the row meets a certain condition it would move the entire row to the respective Master Sheet just below the current data. If it meets condition B it goes to the other master sheet. I can then use Remove Duplicates in Excel to filter the data. My current code is below and I am fairly new to VB Automation. Any ideas on what kind of code I could use to select and move the rows based on criteria into 2 seperate master worksheets?
Sub Copy_DataCDN()
Sheets("CDNDataDump").Range("A2:AC10000").Copy _
Sheets("CDN").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Sheets("CDN").Select
As you suggested, this can be done by looping through the cells in your condition column (in the example code it's column A).
Here's the example code for you to modify.
Sub MoveToSheets()
Dim dataSource As Worksheet: Set dataSource = ThisWorkbook.Sheets(1)
Dim dataTargetA As Worksheet: Set dataTargetA = ThisWorkbook.Sheets(2)
Dim dataTargetB As Worksheet: Set dataTargetB = ThisWorkbook.Sheets(3)
Dim dataSourceRange As Range: Set dataSourceRange = dataSource _
.Range("A1:A" & dataSource.Cells(dataSource.Rows.Count, "A").End(xlUp).Row)
For Each Cell In dataSourceRange
'Test 1 - I'm checking if the cell value is a number as an example.
If IsNumeric(Cell.Value) = True Then
dataTargetA.Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value _
= Cell.EntireRow.Value
'Test 2 - Checking if the cell value is "e".
ElseIf Cell.Value = "e" Then
dataTargetB.Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value _
= Cell.EntireRow.Value
End If
Next
End Sub
In the For Each Cell In dataSourceRange loop you can have as many conditions as you need. You could have more sheets to paste to as well.
I was wondering if there was a way to get all the different autofilter criteria in a list in order to iterate through each criteria, to in the end copy and paste each different table that would appear to a separate sheet as it iterates through.
Ideally this would be run n times:
ActiveSheet.Range(AllRows).AutoFilter Field:=10, Criteria1:=CritVariable
Where n is the number of different CritVariables there are.
I'd like to stress that I know how to copy and paste in the macro itself, but I was curious how to iterate through all the different criteria because the criteria could be different depending on the day. If a list of it isn't available how would I best go about iterating through the criteria?
You can study and adapt the following. Here is an outline of what is going on.
I have a staff-table starting at cell A5, with a list of Offices in
column G;
I'm copying from G5 downwards (assuming there are no blanks in this column's data) to W1;
From range W1 downwards I am removing duplicates;
Then I'm looping through this data, using Advanced Filter to copy the data for each office to an area starting at cell Z1;
This filtered data is then moved (Cut) to a new worksheet, which is named from the current Office name (the criteria);
After each Advanced Filter the cell W2 is deleted, making the value in W3 move up, so that it can be used for the next filter operation.
This does mean that when you press Ctrl-End to go to the last-used cell it goes further than it needs to. You can find a way to resolve this if necessary ;).
Sub SheetsFromFilter()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("W1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
wsCurrent.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, _
wsCurrent.Range("W1:W2"), wsCurrent.Range("Z1")
Set wsNew = Worksheets.Add
wsCurrent.Range("Z1").CurrentRegion.Cut wsNew.Range("A1")
wsNew.Name = wsCurrent.Range("W2").Value
wsCurrent.Range("W2").Delete xlShiftUp
iLeft = iLeft - 1
Loop
wsCurrent.Range("W1").Clear
Application.ScreenUpdating = True
End Sub
BTW I don't intend to modify this for your specific file; this is something that you should do (or pay someone to do ;) ).
BTW It could be done using the normal (rather than Advanced) Filter. You would still copy the column and remove duplicates. This would have the benefit of not increasing the apparent size of the worksheet too much. But I decided to do it this way ;).
Added: Well, I felt inspired to achieve this with AutoFilter as well:
Sub SheetsFromAutoFilter()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("W1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
Set wsNew = Worksheets.Add
With wsCurrent.Range("A5").CurrentRegion
.AutoFilter field:=7, _
Criteria1:=wsCurrent.Range("W1").Offset(iLeft).Value
.Copy wsNew.Range("A1")
.AutoFilter
End With
wsNew.Name = wsCurrent.Range("W1").Offset(iLeft).Value
iLeft = iLeft - 1
Loop
wsCurrent.Range("W1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub
[Both procedures could be improved using Defined Names and some error handling/checking.]
if you want you can build a new collection which will have an array of only unique values and then loop over them. you will know that each
I know it's late and you've already selected an answer, but I'm working on a similar project involving a pivot table and decided to do it this way:
'Here I'm Filtering a column of Week numbers to get rid of non-numbers
'From a pivot table
'I select sheet where my underlying pivot data is located and establish the range
'My data is in column 2 and it ends after "DSLastRow" Rows starting at Row 2
Sheets("DataSheet").Select
DSLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'I create and redim an array that is large enough to hold all of the data in the range
Dim FilterCriteria(): RedimFilterCriteria(1 To DSLastRow)
For r = 2 To DSLastRow 'r for row / my data has a header in row 1
If Cells(r, 2).Value <> "" Then 'again, starting in column B (2)
'Check if it's already in the FilterCriteria Array
For CheckFCA = 1 To r
'Jumps to next row if it finds a match
If FilterCriteria(CheckFCA) = Cells(r, 2).Value Then GoTo Nextr
'Saves the value and jumps to next row if it reaches an empty value in the array
If IsEmpty(FilterCriteria(CheckFCA)) Then
FilterCriteria(CheckFCA) = Cells(r, 2)
GoTo Nextr
End If
Next CheckFCA
End if
Nextr:
Next r
'At this point FilterCriteria() is filled with all of the unique values
'I'm filtering a pivot table which is why I created the unique array from
'the source data, but you should be able to just loop through the table
Sheets("Pivot").Select
ActiveSheet.PivotTables("ReportPivot").PivotFields("Week").ClearAllFilters
With ActiveSheet.PivotTables("ReportPivot").PivotFields("Week")
For FilterPivot = 1 To DSLastRow
'I'm filtering out all non-numeric items
If IsEmpty(FilterCriteria(FilterPivot)) Then Exit For
If Not IsNumeric(FilterCriteria(FilterPivot)) Then
.PivotItems(FilterCriteria(FilterPivot)).Visible = False
End If
Next FilterPivot
End With