I am attempting to create a macro to find values within a specified column and save their location for future use. The values to find are located on another sheet. The end goal is to be able to use the array full of locations to copy information from a few columns over onto a separate sheet.
Below is the code that creates my list....
Dim rng As Range
Dim TempSheet As Worksheet
'Copy list of Vendor IDs to be manipulated
sheets(4).Range("E4:E5000").Select
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
rng.Copy
On Error GoTo 0
Set TempSheet = Sheets.Add
TempSheet.Range("A1").Select
Selection.PasteSpecial (xlValues)
'After Pasting values, change format to number format
[A:A].Select
With Selection
.NumberFormat = "general"
.Value = .Value
End With
'Remove duplicates from list
Range("A:A").RemoveDuplicates Columns:=1
Like I said....I dont even know where to start with this next portion of the coding...
You can use the find function to determine the column location; throw this into a loop of your search values:
k = .Rows(1).Find(What:=SEARCHVALUE, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Column
'may want to look at partials... verify that
'assumed searching in only row 1 for these "headers"
With your known destination, you can do use value=value such that:
wsd = sheets("destination")
wss = sheets("source")
wsd.columns(i).value = wss.columns(k).value
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 need to find the value "5005" (only this value) in column J:J, insert a new row below it, and then fill the row with values in columns A-U.
I am new to VBA and I am unable to do this without making a mess of code.
The draft would look something like this
Find all cells with value 5005 in column J:J,
Insert Row below,
Put value1 in A,
Put Value2 in B,
etc.... until column U,
Repeat on the next cell that has "5005" in it until there are no more
I am unsure what code would work best at this point and I think seeing this written out by a pro would help significantly.
In the messy code I've provided below I was able to search for the value "5005" and insert a line below it, but whatever cell I have selected in excel will be filled with the value "TRUE" and the code is quite messy. Not sure If I was going the right direction with it.
Sub AAAAAAAtest()
Dim find5005 As Range
'Have excel search 1 column instead of all cell
Set find5005 = Cells.Find(What:="5005", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If find5005 Then ActiveCell.Value = find5005.Offset(1).EntireRow.Insert
End Sub
Narrative is in the code comments
Option Explicit
Sub insert5005()
Dim rng As Range, urng As Range, faddr As String
Dim vals As Variant
'get some dummy values quickly
vals = buildAU()
With Worksheets("sheet5")
'find first 5005
Set rng = .Range("J:J").Find(What:="5005", after:=.Cells(.Rows.Count, "J"), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'continue if found
If Not rng Is Nothing Then
'record first found cell
faddr = rng.Address
'start loop for insert, populate and additional cells
Do
'insert new row
rng.Offset(1, 0).EntireRow.Insert
'populate row
.Cells(rng.Offset(1, 0).Row, "A").Resize(1, UBound(vals) + 1) = vals
'look for another
Set rng = .Range("J:J").FindNext(after:=rng)
'keep going until first address is reached a second time
Loop Until rng.Address = faddr
End If
End With
End Sub
Function buildAU()
'construct some dummy values
Dim i As Long, tmp As String
For i = 65 To 85
tmp = tmp & Format(i, "|v\alu\e00")
Next i
buildAU = Split(Mid(tmp, 2), Chr(124))
End Function
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'm trying to create a simple macro for a sheet I use every day at work.
Basically it's about:
Sheet 1 Cell A2:A11 has values in it those values need to be copy pasted into sheet 2 to with an offset each day to the next free column.
What I've got so far is the copy paste with one offset...but I don't know how to say that the offset should happen for the next free column.
Dim rng As Range
Dim ws As Worksheet
Range("A2:A11").Select
Selection.Copy
Sheets("Sheet2").Select
If rng Is Nothing Then
'if nothing found - search for last non empty column
Set rng = ws.Range("2:2").Find(What:="*", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
If rng Is Nothing Then
Set rng = rng.Offset(, 1)
ActiveSheet.Paste
End If
If I understand correctly, try just using this instead of all your current code
Range("A2:A11").Copy Sheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
Set rng = rng.End(xlToRight).Offset(0, 1)
You go all the way right and then one more for the next free column.
I am familiar with programming, but not VBA or the excel object model. I am finding it intensely frustrating to deal with.
What I have is a single sheet of data with column headings. There are a variable number of headings depending on the type of data, so I need to find a specific column (in all sheets) that is not always in the same place (so I cannot hardcode it).
I want to create a sheet for each last name, preferably title it with that name, and then copy from the original sheet to each specific sheet, all ROWs with the name
What I have so far:
Cells.find(What:="Last_Name", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
To find the column with the names. I can then sort the column (which isn't totally necessary, but it helps when doing the copying part manually.)
ActiveCell.Sort key1:=ActiveCell, Order1:=xlAscending, Header:=xlYes
but after that I am struggling to find a way to get the unique items into a list or array or something.
I know how to create a sheet with
Set WS = Sheets.Add
WS.name = "string name goes here"
So the main part is finding a way to iterate over the unique names, making sheets and copying appropriate rows into the sheets with the same name in the sheet as in the row.
Any tips to learn VBA or any other way (.Net somehow?) of interfacing with Excel would be very appreciated.
This should get you close
Sub MakeLastNameSheets()
Dim rLNColumn As Range
Dim rCell As Range
Dim sh As Worksheet
Dim shDest As Worksheet
Dim rNext As Range
Const sLNHEADER As String = "Last_Name"
Set sh = ThisWorkbook.Sheets("Sheet1")
Set rLNColumn = sh.UsedRange.Find(sLNHEADER, , xlValues, xlWhole)
'Make sure you found something
If Not rLNColumn Is Nothing Then
'Go through each cell in the column
For Each rCell In Intersect(rLNColumn.EntireColumn, sh.UsedRange).Cells
'skip the header and empty cells
If Not IsEmpty(rCell.Value) And rCell.Address <> rLNColumn.Address Then
'see if a sheet already exists
On Error Resume Next
Set shDest = sh.Parent.Sheets(rCell.Value)
On Error GoTo 0
'if it doesn't exist, make it
If shDest Is Nothing Then
Set shDest = sh.Parent.Worksheets.Add
shDest.Name = rCell.Value
End If
'Find the next available row
Set rNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Copy and paste
Intersect(rCell.EntireRow, sh.UsedRange).Copy rNext
'reset the destination sheet
Set shDest = Nothing
End If
Next rCell
End If
End Sub
You'll end with one sheet for every last name in your list. If you have 1,000 unique last names, you'll probably crash excel - sheets are limited to available memory. It doesn't copy the header row, but that's easy enough. And it doesn't check for illegal sheet name characters, so if you have any funky last names, you might want to clean out the non-alpha.