how to create macro because values to be copy in DropDown are increasing always. and I have to give Source to Create List in Data Validation - vba

I want to make drop Down List in sheet2 which contains values from sheet1 column. I have tried this code.
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
columns in sheet1 are changing oftenly. so needs to create Dynamic VBA Macro code.
Please guide me for this query.

For your case, I don't think that you need a macro to manage the drop down list but perhaps data validation will do.
Create a new worksheet,
I got a worksheet contain the following data at column A
At the worksheet that i want the dropdownlist, i just highlight the cell and click on the data validation button at data ribbon
In the data validation, create the following setting
Click on the ok button and the list will be created
Since in the columns in the worksheet(source) keep on changing, you need write the macro to copy the entire needed column exclude the header of the column to next worksheet(e.g. worksheet that create the dropdown list).
Edited: Code to detect the criteria column and copy the column
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyWorksheet2 As Worksheet
Dim WantedColumn As Long
Dim ColumnPointer As Long
Sub copyCriteria()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("Sheet6")
Set MyWorksheet2 = MyWorkbook.Sheets("Sheet5")
For ColumnPointer = 1 To MyWorksheet.Cells(1, Columns.Count).End(xlToLeft).Column
If MyWorksheet.Cells(1, ColumnPointer).Value = "ColumnE" Then
MyWorksheet.Columns(ColumnPointer).Copy
MyWorksheet2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
MyWorksheet2.Rows("1:1").Delete Shift:=xlUp
End If
Next
End Sub

What you are trying to do can be done with a simple named range and Data Validation to use that Name. If you have not heard of Dynamic Ranges, then you should read on.
If Sheet1 only has the 1 column for the DropDown list via Data Validation, you should use a Named Range instead of a fixed Range. But this named range is dynamic (by using formula)! See OFFSET usage.
Lets say Sheet1 is like below:
Lets say the name to be used is MyList, then in Excel click Name Manager in Formulas tab, and place in below as the Range Refers to:
=OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A))
Now in Sheet2, the Data Validation is placed on B2, when setting it up, once you put in the source to =MyList, Excel highlights it:
Then the drop down list worked:
Now if you add data to your list (Column A on Sheet 1), the MyList automatically expands and hence your DataValidation drop down list!
Note the list will go up to the first blank cell in Column A, so NO GAPS!
Enjoy!

Related

Is there a way to use VBA to check the value a a certain cell on several different worksheets and display the highest value?

I am trying to loop through a bunch of sheets and check the same cell in each sheet and report back the highest value. I currently have some code that loops through a sheet and copies some data and paste in below and it cycles through all the sheets but I cannot figure out how to get the determine max value part. Data used to copy data from one sheet to another shown below.
Public Sub CopyData()
Dim i As Integer
For i = 2 To ThisWorkbook.Worksheets.Count
'Method 1
Sheets("4-1-21").Range("A53:F100").Copy Destination:=Sheets(i).Range("A53:F100")
'Method 2
'Copy the data
Sheets("4-1-21").Range("A53:F100").Copy
'Activate the destination worksheet
Sheets(i).Activate
'Select the target range
Range("A53:F100").Select
'Paste in the target destination
ActiveSheet.Paste
Application.CutCopyMode = True
Next i
End Sub

Weird activecell.offset output

Sub Link()
Dim Turbidity As Long
Dim RawTurbidity As Range
'Sets variables Turbidity being the ActiveCell and RawTurbidity referring to the last captured cell in raw sheets'
Turbidity = ActiveCell.Row
Set RawTurbidity = Sheets("Raw Data").Range("C4").End(xlDown)
'The formula assigning the last captured cell in Raw sheets to the active cell '
Sheet1.Range(Sheet1.Cells(Turbidity, 4), Sheet1.Cells(Turbidity, 4)).Formula = RawTurbidity
End Sub
So this is the code I have and currently it does what it's suppose to do. We have two sheets atm sheet1 and Raw Data An instrument spits out data into column C of Raw data starting wtih C4 and going all the way down. The current code I wrote in essence paste the newest value the instrument spits out to the active cell in sheet1. I have a code on Raw Data that runs the macro only when a change is made to column C4 and lower. And it works exactly how I want it to however...
my question or issue is that when I add activecell.offset(1,0).select in order to have the activecell automatically go to the next row in sheet1 without me moving the mouse the macro copies and paste the same data into the next 4 cells. If I have the intrument spit out the data again than this time it occupies the next 6 rows with the same data.
Joe B, I think you are making this harder than it is.
Last value in a sheet column gets copied to the next open row in a specified column on another sheet? Is that right?
Option Explicit
Sub Link()
Dim ws1 As Worksheet
Dim wsRaw As Worksheet
Dim ws1LastRow As Long ' "Turbidity"
Dim wsRawLastRow As Long ' "RawTurbidity"
' I suggest you just name the sheets using the developer prop window
'It cuts this whole part out as you can call them directly
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set wsRaw = ThisWorkbook.Worksheets("Raw Data")
ws1LastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row 'lets say you are pasting to column A
'ws1LastRow = ws1LastRow + 1
'There you go the next writable cell row, this is wasted code though, see below you just increment when you need it
wsRawLastRow = wsRaw.Cells(wsRaw.Rows.Count, "C").End(xlUp).Row 'This method doesn't care if your data starts in C4
'No formula needed, it is a straight "copy" here, actually faster as its an assignment
ws1.Cells(ws1LastRow + 1, "A").Value = wsRaw.Cells(wsRawLastRow, "C").Value
'the next open cell (defined by row) in your sheet 1 column is equal to the last row of your Raw Data sheet column
End Sub
Issue is that the data in sheet one is not inputted in order. A person may need the data calculated to row 10 and the next calculation needs to be in row 20 hence the need to copy the data into the active cell.
This was my bad for not stating that in the initial post as it's the primary reason for this strange formula.

Excel VBA For-Next Loop to extract data from one WB to another

I am working on a for loop that extracts entire rows of data based on the string in the 12th column being equal to "Airfare."
The idea is to copy the rows of data where column 12 (EXPENSE_TYPE) is Airfare and paste it into a second workbook.
My code, below, is not properly looping through all 120 rows of data. When I run my macro, it only extracts the first row of data where my criteria is met. Let me know if you can find my issue. Thanks!
Sub exportDataToOtherWorkbook()
Dim lastRow As Long
Dim i As Long
Dim p As Integer
Dim q As Integer
Dim erow As Long
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Cells(i, 12) = "Airfare" Then
Range(Cells(i, 1), Cells(i, 16)).Select
Selection.Copy
Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\Practice Files\masterPracticeExtractDataWBtoWB.xlsx"
p = Worksheets.Count
For q = 1 To p
If ActiveWorkbook.Worksheets(q).Name = "Sheet2" Then
Worksheets("Sheet2").Select
End If
Next q
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
Application.CutCopyMode = False
End If
Next i
End Sub
I would suggest an alternative to looping through each row. Loops are very inefficient and should be avoided if possible.
Assuming your data is stored on "Sheet1" (change to meet your requirements) of the workbook you are copying from, you can filter column 12 and copy all of the data in a more simple command like this:
Sub Test()
'Declare source and destination variables
Dim sourceWB As Workbook, destWB As Workbook
Set sourceWB = ThisWorkbook
'Open the workbook to copy the data TO
Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\Practice Files\masterPracticeExtractDataWBtoWB.xlsx"
Set destWB = ActiveWorkbook
sourceWB.Sheets("Sheet1").Range("A1:P1").AutoFilter Field:=12, Criteria1:="Airfare"
'The first offset on the copy is to avoid copying the headers each time, the second offset is to find the last row in the
'list then offset to the next row. Copies data to new workbook
sourceWB.Sheets("Sheet1").AutoFilter.Range.Offset(1).Copy Destination:=destWB.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
destWB.Save
'Clear the filter from the source worksheet
If sourceWB.Sheets("Sheet1").AutoFilterMode Then sourceWB.Sheets("Sheet1").ShowAllData
End Sub
I know this doesn't directly answer your question, but I think this may be an easier, less error-prone method.
So this method follows these steps:
Open the destination workbook
Filter Sheet1 on column 12 for "Airfare" (be sure to change Sheet1 if necessary)
Copy and paste the filtered range to the destination worksheet and workbook
Remove the filter applied to column 12 in the source worksheet
The confusing part may be the use of Offset(1). I use that on the copy to avoid copying the column headers (it offsets the copy area by one row down). I use it on the destination to avoid overwriting the last row (we must find the last used row, then increment down one row).

Multiple cells selecting and copying to a single row on another worksheet

I've been looking around for this for the past couple days and can't seem to find anything to help me accomplish what I'm trying to do.
I have a sheet that contains data in multiple cells that a user inputs - I would like for when the user hits the submit button that a VBA Macro would copy the data from the multiple cells and paste it into another worksheet on a single row (last row) so I can pull that data later and make changes to it if needed. The worksheet has a unique ID on the top and when searched with that I could pull the data back to the worksheet and make edits to it and save it again.
When I record a Macro and try to multiple select it doesn't let me copy but this is the code that is supplies for the select
Sub Copy()
'
' Copy Macro
'
Union(Range( _
"J22:K22,M22,I24:J24,K24:L24,M24,I26:J26,K26:L26,M26,B29:D29,E29:G29,B30:D30,B31:D31,B33:D33,E33:G33,I29,J29:K29,M29,I31:J31,K31:L31,M31,I33:J33,K33:L33,M33,B36:D36,B37:D37,B38:D38,E36:G36,B40:D40,E40:G40,I36,J36:K36,M36" _
), Range( _
"I38:J38,K38:L38,M38,I40:J40,K40:L40,M40,B2:F3,B2:F3,B6:E6,F7:G7,B7:E7,B8:E8,B9:E9,B11:C11,D11:E11,B13:C13,D13:E13,I3:L3,L2,M1,I6:L6,I7:L7,I8:L8,I9:L9,M7,I11:J11,K11:L11,I13:J13,K13:L13,B15:M16,B18:M19,B22:D22" _
), Range("B23:D23,B24:D24,E22:G22,B26:D26,E26:G26,I22")).Select
End Sub
This is all the cells I need to copy over and paste to a "Entries" Worksheet in the same workbook. I'm sure someone has asked this before but I'm not sure I'm not using the right key words to search but I'm not finding anything. Allot of stuff to copying multiple row and columns and pasting but nothing for multiple cells.
I think this is what you're trying to do
Sub test()
Dim rng As Range
Set rng = Union(Range( _
"J22:K22,M22,I24:J24,K24:L24,M24,I26:J26,K26:L26,M26,B29:D29,E29:G29,B30:D30,B31:D31,B33:D33,E33:G33,I29,J29:K29,M29,I31:J31,K31:L31,M31,I33:J33,K33:L33,M33,B36:D36,B37:D37,B38:D38,E36:G36,B40:D40,E40:G40,I36,J36:K36,M36" _
), Range( _
"I38:J38,K38:L38,M38,I40:J40,K40:L40,M40,B2:F3,B2:F3,B6:E6,F7:G7,B7:E7,B8:E8,B9:E9,B11:C11,D11:E11,B13:C13,D13:E13,I3:L3,L2,M1,I6:L6,I7:L7,I8:L8,I9:L9,M7,I11:J11,K11:L11,I13:J13,K13:L13,B15:M16,B18:M19,B22:D22" _
), Range("B23:D23,B24:D24,E22:G22,B26:D26,E26:G26,I22"))
Dim WSEntries As Worksheet
Set WSEntries = Sheets("Entries")
Dim lastrow As Integer
lastrow = WSEntries.Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
i = 1
For Each c In rng
WSEntries.Cells(lastrow + 1, i) = c
i = i + 1
Next
End Sub
It will iterate through your range left to right from top to bottom.
Are you sure you want to use unionkb though? You could just set your range as all the cells I think it used a union due to the character limit of a function. Did you mean to use intersect kb?
To be clear you're working with three ranges here -
Range("J22:K22,M22,I24:J24,K24:L24,M24,I26:J26,K26:L26,M26,B29:D29,E29:G29,B30:D30,B31:D31,B33:D33,E33:G33,I29,J29:K29,M29,I31:J31,K31:L31,M31,I33:J33,K33:L33,M33,B36:D36,B37:D37,B38:D38,E36:G36,B40:D40,E40:G40,I36,J36:K36,M36")
Range("I38:J38,K38:L38,M38,I40:J40,K40:L40,M40,B2:F3,B2:F3,B6:E6,F7:G7,B7:E7,B8:E8,B9:E9,B11:C11,D11:E11,B13:C13,D13:E13,I3:L3,L2,M1,I6:L6,I7:L7,I8:L8,I9:L9,M7,I11:J11,K11:L11,I13:J13,K13:L13,B15:M16,B18:M19,B22:D22")
Range("B23:D23,B24:D24,E22:G22,B26:D26,E26:G26,I22")
No cells intersect all three ranges.
B2:F3 is twice listed in the second range. Otherwise I don't see any overlap.

Copy cells between workbooks

Could someone please help me with some VBA code.
I am trying to copy 2 ranges of cells between workbooks (both workbooks should be created beforehand as i don't want the code to create a new workbook on the fly).
Firstly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell H5 to the last row in column H with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell B2 for as many cells down in the B column
Secondly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell K5 to the last row in column K with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell D2 for as many cells down in the D column
Here is what I have so far:
Sub CopyDataBetweenBooks()
Dim iRow As Long
Dim wksFr As Worksheet
Dim wksTo As Worksheet
wksFr = "C:\booka.xls"
wksTo = "C:\bookb.xls"
Set wksFrom = Workbooks(wksFr).Worksheets("Sheet 3")
Set wksTo = Workbooks(wksTo).Worksheets("Sheet 1")
With wksFrom
For iRow = 1 To 100
.Range(.Cells(iRow, 8), .Cells(iRow, 9)).Copy wksTo.Cells(iRow, 8)
Next iRow
End With
End Sub
Assuming you have the reference to wksFrom and wksTo, here is what the code should be
wksFrom.Range(wksFrom.Range("H5"), wksFrom.Range("H5").End(xlDown)).Copy wksTo.Range("B2")
wksFrom.Range(wksFrom.Range("K5"), wksFrom.Range("K5").End(xlDown)).Copy wksTo.Range("D2")
Here's an example of how to do one of the columns:
Option Explicit
Sub CopyCells()
Dim wkbkorigin As Workbook
Dim wkbkdestination As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim lastrow As Integer
Set wkbkorigin = Workbooks.Open("booka.xlsm")
Set wkbkdestination = Workbooks.Open("bookb.xlsm")
Set originsheet = wkbkorigin.Worksheets("Sheet3")
Set destsheet = wkbkdestination.Worksheets("Sheet1")
lastrow = originsheet.Range("H5").End(xlDown).Row
originsheet.Range("H5:H" & lastrow).Copy 'I corrected the ranges, as I had the src
destsheet.Range("B2:B" & (2 + lastrow)).PasteSpecial 'and destination ranges reversed
End Sub
As you have stated in the comments, this code above will not work for ranges with spaces, so substitute in the code below for the lastrow line:
lastrow = originsheet.range("H65536").End(xlUp).Row
Now ideally, you could make this into a subroutine that took in an origin workbook name, worksheet name/number, and range, as well as a destination workbook name, worksheet name/number, and range. Then you wouldn't have to repeat some of the code.
You can use special cells like Jonsca has suggested. However, I usually just loop through the cells. I find it gives me more control over what exactly I am copying. There is a very small effect on performance. However, I feel that in the office place, making sure the data is accurate and complete is the priority. I wrote a response to a question similar to this one that can be found here:
StackOverflow - Copying Cells in VBA for Beginners
There is also a small demonstration by iDevelop on how to use special cells for the same purpose. I think that it will help you. Good luck!
Update
In response to...
good start but it doesn't copy anything after the first blank cell – trunks Jun 9 '11 at 5:08
I just wanted to add that the tutorial in the link above will address the issue brought up in your comment. Instead of using the .End(xlDown) method, loop through the cells until you reach the last row, which you retrieve using .UsedRange.Rows.Count.