Using Excel, I'm trying to accomplish the following:
Sample of before & after
I need to convert all the 1's into the corresponding country name of each column. With a small dataset like the sample above, it is easy to do it manually, but not so easy when I have 196 columns x 2 datasets. Any suggestions would be much appreciated!
Duplicate the sheet and clear all the values except the header in the second sheet. Put the following formula in every corresponding cell except the header row in the second sheet.
=IF(INDIRECT(ADDRESS(ROW(),COLUMN(),1,1,"Sheet1"),TRUE)=1,
MID(INDIRECT(ADDRESS(1,COLUMN())),
FIND("[",INDIRECT(ADDRESS(1,COLUMN())))+1,
FIND("]",INDIRECT(ADDRESS(1,COLUMN())))-
FIND("[",INDIRECT(ADDRESS(1,COLUMN())))-1),"")
You can then copy the corresponding cells of the second sheet. Past values into the first sheet. You're done.
{You'll want to remove carriage returns from the formula. Also, you might want to delete the second sheet to hide the magic. :-) }
If you're willing to use vba instead of a formula, I think that this will work for you. It looks for non-empty cells within "A:F" and for those cells it grabs the name inside of [...]
Sub AdjustName()
Dim cell As Range
For Each cell In Range("A2:F" & LastRowInRange_Find(Range("A:F")))
If Len(cell.Value2) > 0 Then
With Cells(1, cell.Column)
cell.Value2 = Mid(.Value2, InStr(.Value2, "[") + 1, Len(.Value2) - 1 - InStr(.Value2, "["))
End With
End If
Next cell
End Sub
Function LastRowInRange_Find(ByVal rng As Range) As Long
'searches range from bottom up looking for "*" (anything)
Dim rngFind As Range
Set rngFind = rng.Find( _
What:="*", _
After:=Cells(rng.row, rng.Column), _
LookAt:=xlWhole, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If Not rngFind Is Nothing Then
LastRowInRange_Find = rngFind.row
Else
LastRowInRange_Find = rng.row
End If
End Function
Related
I have a macro that exactly copies one sheet's data into another.
Sub QuickViewRegMgmt()
("Reg Management").Select
Cells.Select
Selection.Copy
Sheets("Quick View Reg Mgmt").Select
Cells.Select
ActiveSheet.Paste
End Sub
I would like for this macro to also go to the last non-blank cell in Column C (or first blank, I really don't care either way). I tried simple end/offset code, e.g.
Range("A1").End(xldown).Offset(1,0).Select
My problem, however, is that the direct copy macro also copies the underlying formulas, which for Column C is an IF formula. Therefore, no cell in the column is actually empty, but rather they all have an IF formula resulting in a true/false value (respectively, a "" or VLOOKUP).
=IF(VLOOKUP('Reg Management'!$Y260,'Reg Guidance'!$A:$V,3,FALSE)=0,"",VLOOKUP('Reg Management'!$Y260,'Reg Guidance'!$A:$V,3,FALSE))
That means the end/offset code goes to the last cell in the column with the formula (C1000) instead of going to the first cell that has a value of "" (which is currently C260).
What code can I add to this macro to select the first cell that contains an IF formula resulting in a value of "" ---- which has the appearance of being blank?
After trying to be fancy with SpecialCells(), or using Find() or something I couldn't get it ...so here's a rather "dirty" way to do it:
Sub test()
Dim lastRow As Long, lastFormulaRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If Cells(i, 1).Formula <> "" And Cells(i, 1).Value = "" Then
lastFormulaRow = i
Exit For
End If
Next i
End Sub
Edit2: Here's one using .SpecialCells(). Granted I think we can whittle this down more, I like it better:
Sub lastRow()
Dim tempLastRow As Long
tempLastRow = Range("C" & Rows.Count).End(xlUp).Row
Dim lastRow As Range
Set lastRow = Columns(3).SpecialCells(xlCellTypeFormulas).Find(What:="", LookIn:=xlValues, LookAt:=xlWhole, searchdirection:=xlPrevious, after:=Range("C" & tempLastRow))
Debug.Print lastRow.Row
End Sub
It returns 10 as the row.
Edit: Be sure to add the sheet references before Range() and Cells() to get the last row. Otherwise, it's going to look at your active sheet to get the info.
First, my code (below) works, but I am trying to see if it can be simplified. The macro in which this code is located will have a lot of specific search items and I want to make it as efficient as possible.
It is searching for records with a specific category (in this case "Chemistry") then copying those records into another workbook. I feel like using Activate in the search, and using Select when moving to the next cell are taking too much time and resources, but I don't know how to code it to where it doesn't have to do that.
Here are the specifics:
Search column T for "Chemistry"
Once it finds "Chemistry", set that row as the "top" record. e.g. A65
Move to the next row down, and if that cell contains "Chemistry", move to the next row (the cells that contain "Chemistry" will all be together"
Keep going until it doesn't find "Chemistry", then move up one row
Set that row for the "bottom" record. e.g. AX128
Combine the top and bottom rows to get the range to select. e.g. A65:AX128
Copy that range and paste it into another workbook
Here is the code:
'find "Chemistry"
Range("T1").Select
Cells.Find(What:="Chemistry", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'set top row for selection
toprow = ActiveCell.Row
topcellselect = "A" & toprow
'find all rows for Chemistry
Do While ActiveCell = "Chemistry"
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
'set bottom row for selection
bottomrow = ActiveCell.Row
bottomcellselect = "AX" & bottomrow
'define selection range from top and bottom rows
selectionrange = topcellselect & ":" & bottomcellselect
'copy selection range
Range(selectionrange).Copy
'paste into appropriate sheet
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Thanks in advance for any help!
You never need to select or activate unless that's really what you want to do (at the end of the code, if you want the user to see a certain range selected). To remove them, just take out the activations and selections, and put the things on the same line. Example:
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Becomes
wb1.Sheets("Chemistry").Range("A2").PasteSpecial
For the whole code; I just loop thorugh the column and see where it starts and stops being "chemistry". I put it in a Sub so you only have to call the sub, saying which word you're looking for and where to Paste it.
Sub tester
Call Paster("Chemistry", "A2")
End sub
Sub Paster(searchWord as string, rngPaste as string)
Dim i as integer
Dim startRange as integer , endRange as integer
Dim rng as Range
With wb1.Sheets("Chemistry")
For i = 1 to .Cells(Rows.Count,20).End(XlUp).Row
If .Range("T" & i ) = searchWord then 'Here it notes the row where we first find the search word
startRange = i
Do until .Range("T" & i ) <> searchWord
i = i + 1 'Here it notes the first time it stops being that search word
Loop
endRange = i - 1 'Backtracking by 1 because it does it once too many times
Exit for
End if
Next
'Your range goes from startRange to endRange now
set rng = .Range("T" & startRange & ":T" & endRange)
rng.Copy
.Range(rngPaste).PasteSpecial 'Paste it to the address you gave as a String
End with
End sub
As you can see I put the long worksheet reference in a With to shorten it. If you have any questions or if it doesn't work, write it in comments (I haven't tested)
The most efficient way is to create a Temporary Custom Sort Order and apply it to your table.
Sub MoveSearchWordToTop(KeyWord As String)
Dim DestinationWorkSheet As Workbook
Dim SortKey As Range, rList As Range
Set SortKey = Range("T1")
Set rList = SortKey.CurrentRegion
Application.AddCustomList Array(KeyWord)
rList.Sort Key1:=SortKey, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Application.DeleteCustomList Application.CustomListCount
Set DestinationWorkSheet = Workbooks("Some Other Workbook.xlsx").Worksheets("Sheet1")
rList.Copy DestinationWorkSheet.Range("A1")
End Sub
I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.
I am not a programmer but have managed to cobble together great amounts of code that work on 4 pretty large projects (Yay for me!) I have tried numerous ways to find the Last Row. Some work for me some don't. I can find a few that give me the "actual" last row regardless of blanks in Column A (this is what I need). Yet I CANNOT for my life figure how to integrate that code with the way I am passing values from my array from one workbook to another. All of the code works "As Is" but I need to find a better way of searching the whole row (currently columns A:O) for the Last Row and then copying the data over. Column A maybe empty at times and to avoid the code from being overwritten, that "Last Row" needs to check the whole row. I am currently forcing a hidden cell (A7) with a "." as a forced placeholder. Any advice would be awesome.
Option Explicit
Public Sub SaveToLog15()
Dim rng As Range, aCell As Range
Dim MyAr() As Variant
Dim n As Long, i As Long
Dim LastRow As Long
Dim NextCell As Range
Dim Sheet2 As Worksheet
Set Sheet2 = ActiveSheet
Application.ScreenUpdating = False
With Sheet2
' rng are the cells you want to read into the array.
' Cell A7 (".") is a needed "Forced Place Holder" for last row _
determination
' A7 will go away once "better" LastRow can be added to this code
Set rng = Worksheets("Main").Range("A7,D22,D19,D20,J22:J24,E23,D21,J25:J27,D62,D63,G51")
' counts number of cells in MyAr
n = rng.Cells.Count
' Redimensions array for above range
ReDim MyAr(1 To n)
' Sets start cell at 1 or "A"
n = 1
' Loops through cells to add data to the array
For Each aCell In rng.Cells
MyAr(n) = aCell.Value
n = n + 1
Next aCell
End With
On Error Resume Next
' Opens "Test Log.xls"
Workbooks.Open FileName:= _
"S:\Test Folder\Test Log.xls"
' SUBROUTINE 1 "Disable Sheet Protection and Show All" REMOVED
' Finds last row on Tab "Tracking" based on Column "A"
' Last row determination DOES NOT go to next row if first _
Column is blank
' Use A7 "." to always force Data to Col A
'**********************************************************************
'THIS WORKS FINE BUT DOES NOT RECOGNIZE THE POSSIBLE BLANK IN COL A.
With Worksheets("Incoming Data")
Set NextCell = Worksheets("Incoming Data").Cells _
(Worksheets("Incoming Data").Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
' I need this code replaced by the following code or integrated into
' this code snippet. I am lost on how to make that happen.
'***********************************************************************
'***********************************************************************
'THIS CODE FINDS THE "ACTUAL" LAST ROW AND THIS IS WHAT I'D LIKE TO USE
' I need to figure how to integrate this code block with the above
' Or maybe redo the whole thing.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
MsgBox ("The Last Row Is: " & LastRow)
' I am not using this code in the program. It's just there to show
' what I need to use because it works. I need to make this code work
'WITH the above block.
'***********************************************************************
' Sets the size of the new array and copies MyAr to it
NextCell.Resize(1, UBound(MyAr)).Value = (MyAr)
' SUBROUTINE 2 "Add borders to cells in range" REMOVED
' SUBROUTINE 3 "Re-enable Sheet Protection" REMOVED
ActiveWorkbook.Save
'ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "Your Data has been saved to the Log File: " & vbCrLf & vbCrLf _
& "'Test Log.xls'", vbInformation, "Log Save Confirmation"
End Sub
This is a common problem with "jagged" data like:
Clearly here column B has that last row. Here is one way to get that overall Last row by looping over the four candidate columns:
Sub RealLast()
Dim m As Long
m = 0
For i = 1 To 4
candidate = Cells(Rows.Count, i).End(xlUp).Row
If candidate > m Then m = candidate
Next i
MsgBox m
End Sub
:
Find works best for most situations, below is the function i use that takes sheet ref as input and returns row number as type Long
Dim lLastRow As Long
lLastRow = LastUsedRow(shName)
Private Function LastUsedRow(sh As Worksheet) As Long
LastUsedRow = sh.Cells.Find(What:="*", After:=sh.Cells.Cells(1), _
LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
End Function
The simplest thing might be to use the specialcells method, as in range.specialcells(xllastcell). This returns the cell whose row number is the last row used anywhere in the spreadsheet, and whose column is the last column used anywhere in the worksheet. (I don't think it matters what "range" you specify; the result is always the last cell on the worksheet.)
So if you have data in cells B30 and X5 and nowhere else, cells.specialcells(xllastcell) will point to cell X30 (and range("A1").specialcells(xlastcell) will also point to cell X30).
Instead of:
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
MsgBox ("The Last Row Is: " & LastRow)
use this:
LastRow = cells.specialcells(xllastcell).row
MsgBox ("The Last Row Is: " & LastRow)
After 35 attempts this is the code that I was able to hack into my original:
' Used to determine LastRow, LastColumn, LastCell, NextCell
Dim LastRow As Long
Dim LastColumn As Integer
Dim LastCell As Range, NextCell As Range
With Worksheets("Tracking")
' Find LastRow. Works Best. 1st and last cells can be empty
If WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'Search for any entry, by searching backwards by Columns.
LastColumn = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'MsgBox "Last Cell" & vbCrLf & vbCrLf & Cells(LastRow, LastColumn).Address
'MsgBox "The Last Row is: " & vbCrLf & vbCrLf & LastRow
'MsgBox "The Last Column is: " & vbCrLf & vbCrLf & LastColumn
End If
' Number of columns based on actual size of log range NOT MyAr(n)
Set NextCell = Worksheets("Tracking").Cells(LastRow + 1, (LastColumn - 10))
End With
This finds the "Real" Last Row and column and ignores any empty cells in Column A or J which seem to affect some of the LastRow snippets. I needed to make it ROWS instead of ROW and HAD the add the Offset portion as well. (-10) puts me back to Column "A" for my sheet and now I have removed Column "A" {the forced Place Holder "."} and have "Real" data there now. YAY for the "Hacking Code Cobbler".
Glad they pay me at work to learn this stuff. :) Solved this a while back. Just now got to update this post.
I am new to VBA programming. I would like to
search through the worksheet, and find "N" or "TR" on row 6
Then, For every cell in the column of "N" or "TR"
if all the cells are blank, then delete/ hide the column
if the cells are not blank, highlight the cells that are in blank
This sounds easy but I think it requires two for loops.
Sub checkandhide()
Set r = Range("6:6")
Rows("7:7").Select
For Each Cell In r
Selection.Find(What:="N", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
'search for N
Application.Run "hidecolumn"
Next
End Sub
Sub hidecolumn()
Dim target As Range
Dim dwn As Range
Set dwn = Range(ActiveCell.End(xlDown).Address)
ActiveCell.Select
ActiveCell.Offset(6, 0).Select
For Each Cell In dwn
If Cell.Text = "" Then Columns.Delete
Next
End Sub
attached example spreadsheet
You don't need two loops.
You mentioned you want to hide column but your code suggest you delete it (I kept solution which hides)
You didn't mentioned which is empty range (which cells are blank) to decide to hide the column- I assumed everything below 11th row.
Here is the code which is tried and tested with some comments inside it.
Sub checkandhide()
Dim r As Range
Dim Cell As Range
'don't run it for the complete row but from first to last cell in it
Set r = Range("A6", Cells(6, Columns.Count).End(xlToLeft))
For Each Cell In r
'you don't need find if you simply need to check value of the cell
'let's assume we check for 'N' & 'TR' but not 'n' or 'tr'
If Cell.Value = "N" Or Cell.Value = "TR" Then
'there are few possibilities to check if there is any value below _
row 11 (?!) in analysed column. I would use this one:
If Cells(Rows.Count, Cell.Column).End(xlUp).Row < 12 Then
Cell.EntireColumn.Hidden = True
End If
End If
Next
End Sub