I am working on a way to generate a list based on the value of each row in a given column (G). Currently the list can copy entire rows and works perfectly. It pulls all rows if column G contains the required text ("Card") and puts them in a list on another spreadsheet with no gaps.
The problem is that I want the list to only contain information from a few columns in each row containing "Card", not the whole row.
Is there a way to make my code below pull specific cells from a row rather than using the .EntireRow function and copy the whole row?
To clarify, this spreadsheet is updated regularly by multiple different users so the information is not static. Rows are added and changed frequently and occasionally deleted. As such I cannot just copy cell values from the original sheet to the new list.
Sub AlonsoApprovedList()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
Dim ExistCount As Long
ExistCount = 0
MyCount = 1
'----For every cell in row G on the ESI Project Data sheet----'
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000")
If cell.Value = "Card" Then
ExistCount = ExistCount + 1
If MyCount = 1 Then Set NewRange = cell.Offset(0, -1)
'----Sets up a new range to copy all data from the row if column G in that row contains the value in question----'
Set NewRange = Application.Union(NewRange, cell.EntireRow)
MyCount = MyCount + 1
End If
Next cell
If ExistCount > 0 Then
NewRange.Copy Destination:=Worksheets("Alonso Approved List").Range("A3")
End If
End Sub
Additional information:
Column G drop down data validation lists containing one several
items. A complete list is in a different worksheet. Users go in to
each line item and select from a specific category.
The other columns in question contain a line item's name, category
(same as column G), a monetary value, and a date.
The code above loops through a list in the "ESI Project Data" Worksheet and detects rows by the value in cell G. It currently copies the whole row every time a key word is in cell G ("Card") in this example. I am using it to generate individual lists grouped by that key word. I just want it to pull individual cells, not use the .EntireRow function as it currently does. I do not know how to do that.
Thank you for your time!
Untested...
Sub AlonsoApprovedList()
Dim cell As Range
Dim rngDest As Range
Dim i As Long
Dim arrColsToCopy
arrColsToCopy = Array(1, 3, 4, 5)
'----For every cell in row G on the ESI Project Data sheet----'
Set rngDest = Worksheets("Alonso Approved List").Range("A3")
Application.ScreenUpdating = False
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000").Cells
If cell.Value = "Card" Then
For i = LBound(arrColsToCopy) To UBound(arrColsToCopy)
With cell.EntireRow
.Cells(arrColsToCopy(i)).Copy rngDest.Offset(0, i)
End With
Next i
Set rngDest = rngDest.Offset(1, 0) 'next destination row
End If
Next cell
Application.ScreenUpdating = True
End Sub
hello is there a code that I can use to copy specific cells to another workbook by clicking a button.
here's what I am trying to do,
from workbook 1 I need to copy info from the following cells
I have Column B info on cell A40 to A69
I have Column B info on cell b2, b3, b4, b8,9,10,11,12,13,14,15 and b40 to b69
I have column D info on cells b2,
I have column G info on cell b1,b2,b3,b4
all this I need to send it to workbook2 which has the same cells assigned to this specific info.
hope I made my self clear.
Related
I'm working on a project and I need a program that will delete the empty columns (other than the header) in columns A through F and column J. I'd like it to loop through Range("A10:F10000") and Range("J:J") and delete the columns from cell A10, B10, etc and down, then shift the remaining data left. I was working with this, that affects the whole worksheet instead of just a range:
ecl = Sheet1.Cells.SpecialCells(xlCellTypeLastCell).Column
For cl = ecl To 1 Step -1
cnt = Application.WorksheetFunction.CountA(Sheet1.Columns(cl))
If cnt = 1 Then
Sheet1.Columns(cl).Delete
End If
Next
I usually can use formulas and am not super familiar with VBA, but for this project it has to be a macro. I hope this makes sense and would appreciate any advise!
you could use this:
Dim cl As Range, colsToDelete As Range
With ActiveSheet 'reference wanted sheet
Set colsToDelete = .UsedRange.Columns(.UsedRange.Columns.Count).Offset(, 1).Resize(1, 1) ' initialize 'colsToDelete' to a "dummy" range certainly out of relevant one
With Intersect(.Range("A10:J" & .UsedRange.Rows(.UsedRange.Rows.Count).Row), .Range("A:F, J:J")) ' reference referenced sheet range in column A to F and G form row 10 down to referenced sheet last not empty cell row
For Each cl In .Columns ' lop through referenced range columns
If Application.WorksheetFunction.CountA(cl) = 1 Then Set colsToDelete = Union(colsToDelete, cl) 'if current column is empty (i.e. only header in row 10) then add it to the colsToDelete range
Next
Set colsToDelete = Intersect(colsToDelete, .Cells) ' get rid of the "dummmy" range
End With
End With
If Not colsToDelete Is Nothing Then colsToDelete.EntireColumn.Delete ' if any range to delete, do it!
I have a column that contains 50 rows of text. I want to copy each cell and paste its value in a different column, but do so X amount of times based on a separate input. My mind defaults to thinking pythonically, and I want to append each item to a list for manipulation, though I don't think that is necessary in this instance.
Sub fipsloop()
finalRow = Cells(Rows.Count, "P").End(xlUp).Row
p = Worksheets("StateSource").Range("B3:").Select
p_count = WorksheetFunction.CountA(p)
Dim rng As Range, cell As Range
rng = Range("e3:finalRow")
For Each cell In rng
If x.Value = "" Then
Exit For
If p_count > 1 Then
'# here is where I am stuck.
Next cell
"p_count" is the number of times I want to paste each cell's contents into a different column. So if there are 50 items in column E, and my "p_count" variable is 2, then I will paste each item twice and will have 100 items in my new column.
In python I would append each item X amount of times to a list. Is there a way to do something like that within VBA?
Just use the .Value property in your loop. This will copy the value from column 5/E into cells in column 16/P very quickly:
For rowIndex = 1 to p_count
Worksheets("StateSource").cells(rowIndex, 16).Value = Worksheets("StateSource").cells(rowIndex, 5).Value
Next
I have a worksheet "List" which has rows of data that I need to copy to other worksheets. In column "J" of "List", there is a name (Matthew, Mark, Linda, etc.) that designates who's data that row is.
Each of those names (22 in all) has a matching spreadsheet with the same name. I want all rows that say "Linda" in column "J" to paste to worksheet "Linda", all rows with "Matthew" to paste to worksheet "Matthew", etc.
I have some code below, which mostly works, but I'd have to rewrite it for all 22 names/sheets.
Is there a way to loop through all the sheets, pasting the rows with matching names? Also, the code below works really slowly, and I'm using data sets with anywhere from 200 to 60,000 rows that need sorted and pasted, which means that if its slow on a small data set like the one I'm currently working on, and only for one sheet, it's going to be glacially slow for the big data sets.
Sub CopyMatch()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = Worksheets("List")
Set Target = Worksheets("Linda")
j = 4 ' Start copying to row 1 in target sheet
For Each c In Source.Range("J4:J1000") ' Do 1000 rows
If c = "Linda" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
Unless you've turned calculation off somewhere we can't see here, then every time you copy a row, Excel is recalculating - even if your sheets contain no formulas.
If you're not doing so already, simply putting:
application.calculation=xlcalculationmanual
before you start your loop and:
application.calculation=xlcalculationautomatic
after exiting the loop will massively speed up your loop. For extra swank, you can use a variable to store the calculation setting before you turn it off and restore that setting at the end, e.g.
dim lCalc as long
lCalc = application.calculation
application.calculation = xlcalculationmanual
for ... next goes here
application.calculation = lCalc
Also consider other settings, e.g.: application.screenupdating=False|True.
Sort the data by the name you're selecting on, then by any other sorts you want. That way you can skip through any size sheet in 22 steps (since you say you have 22 names).
How you copy the data depends on preference and how much data there is. Copying one row at a time is economical on memory and pretty much guaranteed to work, but is slower. Or you can identify the top and bottom rows of each person's data and copy the whole block as a single range, at the risk of exceeding the memory available on large blocks in large sheets.
Assuming the value in your name column, for the range you're checking, is always one of the 22 names, then if you've sorted first by that column you can use the value in that column to determine the destination, e.g.:
dim sTarget as string
dim rng as range
sTarget = ""
For Each c In Source.Range("J4:J1000") ' Do 1000 rows
if c <> "" then ' skip empty rows
if c <> sTarget then ' new name block
sTarget = c
Set Target = Worksheets(c)
set rng = Target.cells(Target.rows.count, 10).end(xlup) ' 10="J"
j = rng.row + 1 ' first row below last name pasted
end if
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
end if
Next
This is economical of memory because you're going row by row, but still reasonably fast because you're only recalculating Target and resetting j when the name changes.
you could use:
Dictionary object to quickly build the list of unique names out of column J names
AutoFilter() method of Range object for filtering on each name:
as follows
Option Explicit
Sub CopyMatch()
Dim c As Range, namesRng As Range
Dim name As Variant
With Worksheets("List") '<--| reference "List" worskheet
Set namesRng = .Range("J4", .Cells(.Rows.count, "J").End(xlUp)) '<--| set the range of "names" in column "J" starting from row 4 down to last not empty row
End With
With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "names" range cells with text content only
.item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
Next
Set namesRng = namesRng.Resize(namesRng.Rows.count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
Next
End With '<--| release the 'Dictionary' object
End Sub
Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
Dim destsht As Worksheet
Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
With rangeToFilter
.AutoFilter Field:=1, Criteria1:=nameToFilter
Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.count, "J").End(xlUp)
.Parent.AutoFilterMode = False
End With
End Sub
I receive a monthly aging report. I need to compare these 2 reports to find out what items appear on each of the reports. I need a VBA to look at Column B of both sheets and if there is a match, extract those rows only. In addition, I need a vba to find out if something has changed. For those that are not familiar with aging report, this reports tells me how far the customer is past due in paying me. So if customer 1, was in the Aging 0-30 (Column S) on report pulled on 20151023, then on the report pulled 20160223, this customer should be in Aging 90-120 (Column V). I'm thinking the best way to display this information is to display matched data with no changes in the No Changes Sheet. Then, in the sheet called Changes, I would like to display about 6 columns of information: Report Date, Dealr, Contract Number, Status, Aging History, & AR Amount. The Aging History will tell me what bucket this customer was on when the report was pulled. This information will come from the column headings (S-X). The AR Amount will be the amount appearing in that column. I will try to upload a sample.
The following gives you a way to compare the same column in two sheets. The first way looks for a matching value anywhere in the second sheet's column, the second method only returns a match if the matching cells are on the same row in both sheets
Sub CompareSheets(sheet1 As Worksheet, sheet2 As Worksheet, columnNumber As Long)
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1Data As Range, ws2Data As Range
Dim col As Long
Dim i As Integer
Dim cell1 As Range, cell2 As Range
Set ws1 = sheet1
Set ws2 = sheet2
col = columnNumber
ws1Data = ws1.Columns(col).Cells
ws2Data = ws2.Columns(col).Cells
Find a match anywhere in either column
' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
' This code will find any match between the two sheets
' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Checks each cell in the target column of sheet 1
For Each cell1 In ws1Data
'Checks each cell in the target column of sheet 2
For Each cell2 In ws2Data
'If the cell from sheet 1 matches any cell in sheet 2 then do stuff
If cell1 = cell2 Then
'Do stuff with the data here
End If
Next cell2
Next cell1
' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Find a match only if the matching cells are on the same row
' ////////////////////////////////////////////////////////
' This code will find a match ONLY if both entries are
' on the same row in their respective sheets
' ////////////////////////////////////////////////////////
'Checks each cell in the target column of sheet 1
For Each cell1 In ws1Data
'Checks each cell in the target column of sheet 2
For Each cell2 In ws2Data
'If the cell from sheet 1 matches any cell in sheet 2
'AND there are on the same row in both sheets then do stuff
If (cell1 = cell2) And (cell1.Row = cell2.Row) Then
'Do stuff with the data here
End If
Next cell2
Next cell1
' /////////////////////////////////////////////////////////
' /////////////////////////////////////////////////////////
End Sub
Then you can make a button or macro that calls the sub
Call CompareSheets(firstworksheet, secondworksheet, 2) '2 is the column number for B
A proper example
Call CompareSheets(Worksheets(1), Worksheets(2), 2)
As for what you want to do with the matches once they're located, that's really for another post.
Let me preface this question by saying I am not super technical so much of my verbiage may seem obscure..
On sheet1 I have three seperate horizontal ranges of cells (3 seperate series of steps):
A1:D1
A2:C2
A3:E3
On sheet two, I'd like to link to create live links to these ranges, such that if I change information on sheet1, it will be automatically reflected in sheet2.
The catch is, that on sheet2, I want the ranges to be listed after one another in one row, to create one long series of steps.
Range1-->Range2-->Range3 (all on one row)
How do I ensure that if I add an additional step to, say, the first range on sheet1, that on sheet 2, the new cell will be added and the following cells will all be pushed over to the right by one cell?
To accommodate ranges that might grow, start from the first cell and then find the last occupied cell with End(xlToRight). Once you've found all the range extents, you can combine them with an array UDF:
Function ConcatRanges(ParamArray ranges()) As Variant()
Application.Volatile
Dim ret() As Variant
ReDim ret(1 To 1, 1 To (Application.Caller.Columns.Count))
Dim RetIdx&, i&, cell As Range
RetIdx = 1
For i = 0 To UBound(ranges)
For Each cell in Application.Range(ranges(i), ranges(i).End(xlToRight))
ret(1, RetIdx) = cell.Value
RetIdx = RetIdx + 1
Next
Next
For RetIdx = RetIdx To UBound(ret, 2)
ret(1, RetIdx) = vbNullString
Next
ConcatRanges = ret
End Function
For your example, you'd call it like this:
=ConcatRanges(Sheet1!A1, Sheet1!A2, Sheet1!A3)