Making a sheet where the user can select an area from a drop down, and then cells containing info relevant to that area are shown in column T.
The data is formatted in such a way that the areas are the headings across the columns from A1:Q1. Then on each column is a combination of blank cells and cells that contain the info needed.
This shows a simplified example of what I'd like to do. Obviously the X's pertain to actual info.
I've got a code that I think should work, but it's not.... The first section does successfully find the right column from the sheet using whatever is in the drop down. But then the copy paste loop that looks for blank cells does not seem happy, and doesn't want to use the address I found from the find section.
I did explore the idea of using index/match/array, but couldn't get my head round it.
Sub NonBlank()
Dim Found As Range
Dim Clm As String
Dim rngSearch As Range
Dim Criteria As Variant
Dim cell As Range
Criteria = Sheets("Example").Range("S3").Value
Set rngSearch = Sheets("Example").Range("A1:Q1")
Set Found = rngSearch.Find(What:=Criteria, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
Clm = Found.Address(rowabsolute:=False)
Dim datatocopy As Range
Set datatocopy = Sheets("example").Range("clm").SpecialCells(xlCellTypeConstants)
If Not datatocopy Is Nothing Then
datatocopy.Copy Destination:=Sheets("Example").Range("T3")
End If
End If
End Sub
Any help is much appreciated. :)
If the values are constants and no formulas you don't need to loop through the data and can just use SpecialCells(xlCellTypeConstants) on the range to get all constant values (without the blank cells).
Dim DataToCopy As Range
Set DataToCopy = Sheets("Table").Range("B1:B6").SpecialCells(xlCellTypeConstants)
If Not DataToCopy Is Nothing Then
DataToCopy.Copy Destination:=Sheets("Table").Range("G2")
End If
The following should work
Sub NonBlank()
Dim Criteria As Variant
Criteria = Sheets("Example").Range("S3").Value
Dim rngSearch As Range
Set rngSearch = Sheets("Example").Range("A1:Q1")
Dim Found As Range
Set Found = rngSearch.Find(What:=Criteria, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
Dim datatocopy As Range
Set datatocopy = Found.EntireColumn.Resize(RowSize:=Rows.Count-1).Offset(RowOffset:=1).SpecialCells(xlCellTypeConstants)
If Not datatocopy Is Nothing Then
datatocopy.Copy Destination:=Sheets("Example").Range("T3")
End If
End If
End Sub
Related
I'm trying to copy data from a column in a sheet called "KPI", in cells H6:H100, to a specific row in a sheet named "table". The row depends on two variables in the KPI sheet which user selects from drop downs in C2:D2.
I have managed to get the code to find the right row each time by searching columns A then B in the "data" sheet.But when it comes to the copy paste/transpose column H from "KPI" sheet into the right row on the "table" sheet it throws up a 424 error.
I might be missing something really obvious so any help is appreciated.
Sub copy_transpose()
Dim rng_source As Range
Dim Found As Range, Firstfound As String
Dim rngSearch As Range
Dim Criteria As Variant
Set rng_source = ThisWorkbook.Sheets("KPI").Range("H6:H100")
Set rngSearch = Sheets("Table").Range("A:A")
Criteria = Sheets("KPI").Range("C2:D2").Value
Set Found = rngSearch.Find(What:=Criteria(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
Firstfound = Found.Address
Do
If Found.EntireRow.Range("B2").Value = Criteria(1, 2) Then Exit Do 'Match found
Set Found = rngSearch.FindNext(After:=Found)
If Found.Address = Firstfound Then Set Found = Nothing
Loop Until Found Is Nothing
End If
If Not Found Is Nothing Then
Application.Goto Found
rng_source.Copy
Sheets("Table").Range(cell.Offset(0, 1), cell.Offset(0, 7)).PasteSpecial Transpose:=True
Else
MsgBox ("Error")
End If
End Sub
I needed more coffee. I hadn't spotted that is was referencing "cell" instead of "found".
Today I learned that "cell" is not a vba function, and was actually something I had dimensioned in my older code, and was the equivalent of "found".
I have been trying to write a script that selects a starting cell based on a search input, and then sets the range between the starting cell and the last cell before an empty cell.
At the moment this is what I have (the search script is separate, but it functions fine and selects the correct starting cell):
Dim PDFfiles As Range
Dim PDFfile As Variant
Dim n As Long
Dim rngFileStart, rngFileEnd As Variant
Dim StCell As Variant
'Set start point of cell range
'Takes ActiveCell from search results and offsets to filepaths
With ThisWorkbook.Worksheets("PRODUCT REGISTER")
Set StCell = ActiveCell
Set rngFileStart = Range("D6:D18")
Set rngFileEnd = rngFileStart.Find(What:=Empty, After:="D6", LookIn:=xlValues, SearchOrder:=xlByColumns, Searchdirection:=xlNext)
Set PDFfiles = .Range(rngFileStart, rngFileEnd - 1)
End With`
It is failing at the last line, as rngFileEnd returns as nothing. Just wondering where I am going wrong and why it is not returning a value to use in setting my PDFfiles range.
In this line:
Set rngFileEnd = rngFileStart.Find( _
What:=Empty, _
After:="D6", _
LookIn:=xlValues, _
SearchOrder:=xlByColumns, _
Searchdirection:=xlNext)
the After parameter needs to refer to a single cell.
Using "D6" refers to the string "D6" and not the cell.
Use any of:
After:=Range("D6")
After:=[D6]
After:=Cells(6,4)
instead.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.range.find
https://learn.microsoft.com/en-us/office/vba/excel/concepts/cells-and-ranges/refer-to-cells-by-using-shortcut-notation
I have an excel spreadsheet which generate different column names every time, but has the same starting word.
So for example, I could have a column with the name "Key" , after 2 to three columns there would columns with names as key3,key29 likewise I have another word called value and then value1,value2 after some columns value6,value7 etc
What I want to do is to search the columns names in the sheet Rows("1:1").Select and select the entire column if a text matches to the value I assign and finally copy it to separate sheet.
So far this is what I tried.
Rows("1:1").Select 'Selecting the columns row
' Finding values with name i want to look for
Selection.Find(What:="key", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate.Select
Option Explicit
Sub test()
Dim cell As Range, rng As Range
Dim SearchString As String
Dim LastColumn As Long
SearchString = "Test"
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Rows("1")
For Each cell In rng.Cells
If InStr(1, cell.Value, SearchString) > 0 Then
LastColumn = ThisWorkbook.Worksheets("Sheet2").Cells(1, ThisWorkbook.Worksheets("Sheet2").Columns.Count).End(xlToLeft).Column
.Columns(cell.Column).Copy ThisWorkbook.Worksheets("Sheet2").Columns(LastColumn + 1)
End If
Next
End With
End Sub
The code below will give a great start. Adjust any worksheet, cell and range references as needed. There's also a ton of resources on what each method I used does in case anything is unfamiliar to you.
With Worksheets("Sheet1")' change as needed
Dim lastRow as Long
lastRow = .Cells(.Rows.Count,1).End(xlUp).Row 'change column as needed
Dim headers as Range
Set headers = .Range("A1",.Cells(1,.Columns.Count).End(xlToLeft))
Dim findIt as String
findIt = "key"
Dim cel as Range
For each cel in headers
If cel.Text like "*key*" Then
.Range(cel,.Cells(lastRow, cel.Column)).Copy worksheets("sheet2").Cells(1,cel.Column) 'change sheet and column as needed
End if
Next
End With
I am trying to select the last row of my table and use an outside border around the whole row up until the last column. Here is my Code
Cells(Application.Rows.Count, .Columns.Count).End(xlUp).BorderAround Weight:=xlMedium
Before I had
Cells(Application.Rows.Count, 1).End(xlUp).BorderAround Weight:=xlMedium
My second line of code only bordered the first cell. I need it to outside border all the cells in the row. I have tried different things like turning it into a "range" to only get an error. These are my closest attempts. I do not get an error but it does not do what I need it to do.
Thanks,
G
Find the table
Find the last row
Optionally clear any existing borders
Create a range object encompassing the last row (or whatever part you want to border).
Use the BordersAround property to draw the borders
Option Explicit
Sub BorderAroundBottom()
Dim WS As Worksheet
Dim rFirst As Range, rLast As Range, rTable As Range
'Need to know where table starts
Const ColHdr As String = "ColA"
Set WS = Worksheets("sheet2")
'Find first cell of the table
'Can hardcode this if known
With WS.Cells
Set rFirst = .Find(what:=ColHdr, after:=.Cells(.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If rFirst Is Nothing Then
MsgBox "First Column Header not found"
Exit Sub
End If
Set rLast = .Cells(.Rows.Count, rFirst.Column).End(xlUp)
Set rLast = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
Set rTable = .Range(rFirst, rLast)
End With
With rTable
.Borders.LineStyle = xlNone
.Rows(.Rows.Count).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
End With
End Sub
The problem is that in both of your code attempts, you are only selecting one cell. Because you are using the Cells method, you are only selecting a single cell. You need to use Cells in conjunction with the Range object to get a multicellular region.
Assuming your data starts in cell A1 on Sheet1, here is working code:
Sub DrawBorder()
Dim rngBottomRowStart As Range
Dim rngBottomRowEnd As Range
Dim rngDataUpperLeftCell As Range
Set rngDataUpperLeftCell = Sheet1.Range("A1")
With rngDataUpperLeftCell
Set rngBottomRowStart = Sheet1.Cells(.End(xlDown).Row, .Column)
Set rngBottomRowEnd = Sheet1.Cells(rngBottomRowStart.Row, .End(xlToRight).Column)
End With
Sheet1.Range(rngBottomRowStart, rngBottomRowEnd).BorderAround Weight:=xlMedium
End Sub
I've got part of a solution but it isn't working like I'd hope, so I've come to you for advice.
I regularly receive Excel files where I need to amend formatting. I'm trying to learn VBA by automating as much of these procedures as possible.
One particular format I complete is converting the date to "DDMMYYYY" (09091986), where it usually comes in as 09/09/1986.
Within my worksheet, there are a total of 3 columns containing dates, all of which need the same formatting and all of which have the word "DATE" in the heading. They are not adjacent to each other.
I must also be careful not to have any other data affected, as I have names and addresses which may contain the characters "DATE".
So, background out of the way... I'm trying to search the first row until I find the word "Date" and then format that for each cell until the last row, before moving on to the next column containing the word "DATE" and repeating this until all columns with the word "DATE" have been formatted.
I'm sure you have a simple solution but I can't seem to find it myself.
Here is the code I have...
Sub Dateformat()
Dim LastRow As Integer
Dim FindCol As Integer
Dim C1 As Integer
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
FindCol = Cells.Find(What:="DATE", LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Column
For C1 = 2 To LastRow
Cells(C1, FindCol).NumberFormat = "DDMMYYYY"
Next C1
End Sub
This works for the first column containing date but doesn't move on to the next column.
Thanks for the help
Regards,
Adam
As you know, you need to loop through and find each Row Header with DATE
Here is one way to do it.
Sub Dateformat()
Dim wks As Worksheet
Dim LastRow As Integer
Dim FindCol As Range
Dim sAdd As String
Set wks = ThisWorkbook.Sheets("Sheet1") ' adjust as needed
With wks
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find first instance where DATE exists in row 1 (headers)
Set FindCol = .Rows(1).Find(What:="DATE", LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
'store address of first found instance (to check in loop)
sAdd = FindCol.Address
Do
'format column (row 2 to last used row)
.Range(.Cells(2, FindCol.Column), .Cells(LastRow, FindCol.Column)).NumberFormat = "DDMMYYYY"
'this line works as well and is a bit cleaner
'.Cells(2, FindCol.Column).Resize(LastRow - 1, 1).NumberFormat = "DDMMYYYY"
'find next instance (begin search after current instance found)
Set FindCol = .Cells.FindNext(After:=FindCol)
'keep going until nothing is found or the loop finds the first address again (in which case the code can stop)
Loop Until FindCol Is Nothing Or FindCol.Address = sAdd
End With
End Sub