Below is a Sub that is being used to format all cells as text in the spreadsheet starting with worksheet3 onwards. As you'll see there's a line in bold that I will most likely need to change. One of the purposes of the line is to keep the values of the Column1 ("Client ID") intact because in every sheet it consists '00001' values that converted with this code would change to '1'. That's wrong. Important thing is that Column1 in every worksheet always contains the same '00001' values.
Sub formatAllCellsAsText()
Dim wsTemp As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim Cell As Range
For sht = 3 To Worksheets.Count
Set wsTemp = Sheets(sht)
Set StartCell = wsTemp.Range("A4")
LastRow = wsTemp.Range("A4").CurrentRegion.Rows.Count
LastColumn = wsTemp.Range("A4").CurrentRegion.Columns.Count
For Each Cell In wsTemp.Range(StartCell, wsTemp.Cells(LastRow, LastColumn)).Cells
If Not IsEmpty(Cell.Value) And IsNumeric(Cell.Value)
And InStr(wsTemp.Cells(1, Cell.Column), "Client ID") <= 0 Then
Dim Temp As Double
Temp = Cell.Value
Cell.ClearContents
Cell.NumberFormat = "#"
Cell.Value = CStr(Temp)
End If
Next
Next sht
End Sub
Now my problem is that in one worksheet there's Column6 ("Value") that I want to preseve 000s in front of a number. When I change the line to the following my macro still removes preceding 000s from the Column6 values. I guess the condition is not as straightforward as I have thought.
If Not IsEmpty(Cell.Value) And IsNumeric(Cell.Value) And
InStr(wsTemp.Cells(1, Cell.Column), "Client ID") <= 0 And
InStr(wsTemp.Cells(6, Cell.Column), "Value") <= 0 Then
Any suggestions?
Pls try this:
Sub formatAllCellsAsText()
Dim wsTemp As Worksheet
Dim LastRow As Long, LastColumn As Long
Dim StartCell As Range, Cell As Range
Dim Temp As Double
Dim Temp2 As String
For sht = 3 To Worksheets.Count
Set wsTemp = Sheets(sht)
Set StartCell = wsTemp.Range("A4")
LastRow = wsTemp.Range("A4").CurrentRegion.Rows.Count
LastColumn = wsTemp.Range("A4").CurrentRegion.Columns.Count
For Each Cell In wsTemp.Range(StartCell, wsTemp.Cells(LastRow, LastColumn)).Cells
If Not IsEmpty(Cell.Value) And IsNumeric(Cell.Value) And InStr(wsTemp.Cells(1, Cell.Column), "Client ID") <= 0 Then
Temp = Cell.Value
Temp2 = Cell.NumberFormat
Cell.ClearContents
Cell.NumberFormat = "#"
Cell.Value = Format(Temp, Temp2)
End If
Next
Next
End Sub
You simply check for the number format and then apply it to the string. This way "0001" stays "0001". Another way would be the use of .Text
Dim Temp As String
Temp = Cell.Text
Cell.ClearContents
Cell.NumberFormat = "#"
Cell.Value = Temp
You also can do this only if If IsNumeric(Cell.Value) And Left(Cell.Text, 1) = "0" Then is true, so that rule only applies to cells with numerical values having leading zeros ;)
Column1 in every worksheet always contains the same '00001' values.
Change the line
Cell.Value = CStr(Temp)
to
Cell.Value = Format(Temp,"00000")
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
Hi there I am trying to select a range "A2:H2" down to the last filled cell based on column A (so in this case it should select "A2:H59"). The range is not fixed so it cannot be defined with exact numbers. I have the following code, but it selects everything down to the 402nd row even though there is no data beyond "A59" in the sheet. Any idea what is going on? Thanks for the help!
Global ssaw As Worksheet
Global trckr As Worksheet
Sub DataF()
Dim myRange As Range
Dim myCell As Range
Set ssaw = Sheets("SSAW_DATA")
Set trckr = Sheets("SQL_DATA_FEED")
Set myRange = trckr.Range("A2:H2").end(xlDown)
With myRange
.SpecialCells(xlCellTypeBlanks).Interior.Color = RGB(255, 102, 102)
.SpecialCells(xlCellTypeBlanks).Value = "#missing#"
End With
End Sub
If we assume your last used cell in column A is A59 then …
… This
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown))
will select A2:A59 and this
.Resize(ColumnSize:=8)
will resize it to make it 8 columns width that is A2:H59.
So together we get:
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown)).Resize(ColumnSize:=8)
Use this
trckr.Range("A" & trckr.Rows.Count).End(xlUp)
alternatively to find the last used cell in column A if there can be empty cells in between:
Set myRange = trckr.Range("A2", trckr.Range("A" & trckr.Rows.Count).End(xlUp)).Resize(ColumnSize:=8)
exploit the fact that Range(cell1, cell2) is equivalent to Range(cell2, cell1)
Set myRange = trckr.Range("H2", trckr.Range("A2").End(xlDown))
while if you want to select a range from A2:H2 down to column A last not empty cell (i.e. included empty cells along column A in between the first and last not empty ones):
Set myRange = trckr.Range("H2", trckr.Cells(trckr.Rows.Count, 1).End(xlUp))
I would suggest to use the following code
Option Explicit
Function LastRowInColumn(colName As String)
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
LastRowInColumn = lastRow
End Function
Sub SelectRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
lastRow = LastRowInColumn("A")
Debug.Print lastRow
If lastRow = 1 Then
' do nothing
Else
Set wks = ActiveSheet
With wks
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
rg.Select
End With
End If
End Sub
The code determins the last filled row in column A and select based on this information everything to column H
EDIT Improved function
Function LastRowInColumn(ByVal wks As Worksheet, ByVal colName As String) As Long
With wks
LastRowInColumn = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
End Function
EDIT2 And if one would not like to use an extra function you could do it like that
Sub SetRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
Set wks = ActiveSheet
With wks
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'lastRow = LastRowInColumn(wks, "A")
If lastRow > 1 Then
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
End If
End With
End Sub
I would like to apply filter on a table based the values presented in cells A1:AG1. But the problem is when my data gets updated, sometimes i have values in other cells like AH,AI etc., The values available only on first row.
So i tried to add a loop for every cell, but it is not working. How to change my code to loop through every column in a single row. Help me
Dim ws As Worksheet
Dim str2 As Variant
Dim arr2() As String
Dim j As Long
Dim rng As Range
Set ws = Sheets("Main")
Set Tbl = Sheet2.ListObjects("DataTable")
Set rng = Range("A1:AG1") 'Need to change
j = 1
For Each cell In rng
str2 = cell.Value
ReDim Preserve arr2(j)
arr2(j) = str2
j = j + 1
Next cell
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
End sub
How about something like below:
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim arr2() As String
Dim i As Long
Set ws = Sheets("Main")
Set ws2 = Sheets("Sheet2")
Set Tbl = ws2.ListObjects("DataTable")
LastCol = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
'above will give you the last column number in row one of sheet ws2
ReDim Preserve arr2(1 To LastCol) 're-size the array
'Set rng = Range("A1:A" & LastCol) 'set your range from column 1 to last
For i = 1 To LastCol 'loop through columns
arr2(i) = ws2.Cells(1, i).Value 'add value to array
'above number 1 represents Row 1, and i will loop through columns
Next i
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
'above will filter table column 12 with array values?
I do not know if I understood your question well, but just replace:
Set rng = Range("A1:AG1")
With:
Set rng = ws.range(ws.cells(1 , 1) , ws.cells(1 , ws.Cells.Columns.Count).End(xlToLeft).Column
I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub
I currently have the following code:
Dim TrimThreshold As Integer
Dim Counter As Integer
Dim CurrentColumn As String
Set ws1 = ActiveWorkbook.Sheets("Data HUB")
Set ws2 = ActiveWorkbook.Sheets("sheet2")
TrimThreshold = Sheets("sheet2").Range("B3").Value
Counter = 0
CurrentColumn = "B2"
Sheets("Data HUB").Activate
For Each cell In Range(CurrentColumn, Range(CurrentColumn).End(xlDown))
If cell.Value >= TrimThreshold Then
Sheets("sheet2").Range("C3").Offset(Counter, 0).Value = 1
Counter = Counter + 1
Else
Sheets("sheet2").Range("C3").Offset(Counter, 0).Value = 0
Counter = Counter + 1
End If
Next cell
This code successfully works for 1 column but is there anyway to assess for a variable range of both columns and rows? For instance, my data may look like the attached picture:
but the columns and rows may be variable between data worksheets (the columns and rows will always be equal within a single worksheet though!)
The final output will be a binary number (either 1 or 0) in the next tab of the worksheet determined if the value of the cell is greather than the threshold value entered in a cell (sheet2.cell"B3" in this case).
Thank you!
Should be self-explaining:
Option Explicit
Sub Macro1()
With Sheets("Data HUB")
Dim inRange As Range
Set inRange = .Range("B2")
Set inRange = .Range(inRange.End(xlToRight), inRange.End(xlDown))
Dim wsOut As Worksheet
Set wsOut = ActiveWorkbook.Sheets("sheet2")
Dim TrimThreshold As Long
TrimThreshold = wsOut.Range("B3").Value
Dim outRange As Range
Set outRange = wsOut.Range("C3").Resize(inRange.Rows.Count, inRange.Columns.Count)
outRange.Value = .Evaluate("(" & inRange.Address & ">=" & TrimThreshold & ")*1")
End With
End Sub
If you still have any questions, just ask :)