I am searching for a column in vba that has a certain header and then when I find that I want to search all the rows in that column and replace all the X's with 1's. I have all the code written but for some reason its not allowing the line shown below:
r2 = Range(i, i).EntireColumn.Rows.Count
Sub PA_Change()
Dim i As Long, r As Range, rRow As Range, r2 As Long
Set r = Range("A1")
Set rRow = r.EntireRow
For i = 1 To rRow.Columns.Count
If Cells(1, i) = PA_REQUIRED Then
r2 = Range(i, i).EntireColumn.Rows.Count
For j = 1 To r2
If Cells(j, i).Value = "X" Then
Cells(j, i).Value = "1"
End If
Next j
End If
Next i
End Sub
Try replacing all your code with this and let us know if that works:
*replace the "boo" in searchFor with the actual header name / PA_REQUIRED
Sub PA_Change()
Dim searchFor As String
searchFor = "boo"
Dim grabColumn As Range
Set grabColumn = Rows("1:1").Find(What:=searchFor, _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If Not grabColumn Is Nothing Then
Dim entireColumn As Range
Set entireColumn = Range(grabColumn.Address & ":" & Split(grabColumn.Address, "$")(1) & Range(Split(grabColumn.Address, "$")(1) & Rows.Count).End(xlUp).Row)
Dim cell As Range
For Each cell In entireColumn
If UCase(cell) = "X" Then
cell = "1"
End If
Next
Else
Exit Sub ' not found
End If
End Sub
Related
some time ago I posted a similar question here and got a great answer. But now I would need a slightly altered code but I am not able to change it up.
In an Excel sheet I have cells which have values but all cells between those two are empty. I want Excel to fill the empty cells between them with the values of a third cell. To visualise:
That's what it looks like
Now I want the macro to fill out all the empty cells with the value of the corresponding J cell. So it would look like this:
From the previous thread I used this code:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Is it possible to change up the existing code? Or maybe the other code from my previous, linked question? I looked into both but I myself unfortunately wasn't able.
Any help is appreciated. Thanks in advance.
Use the code from the your other question but change rowval to look at column J
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, 10).Value --This is all I changed
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
Answer with modifying previous code
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = Cells(.Areas(1).Row, "J").Value
End With
Next
End Sub
Assuming you have three values in each row and they are not consecutive, a small change to your original code should suffice.
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = .Areas(3).Value
End With
Next
End Sub
This will do exactly what you want in three lines
Sub FillBlanks()
Dim c
For Each c In ActiveSheet.UsedRange.Columns("J").SpecialCells(xlCellTypeConstants)
Range(c.Offset(0, c.End(xlToLeft).Column - c.Column), c.Offset(0, -c.Column + 1)).SpecialCells(xlCellTypeBlanks).Value2 = c.Value2
Next c
End Sub
I am currently trying to write some VBA code which will fill out all cells between two cells with the value of the two cells.
Here is what I have :
And I would like the code to fill out all cells in between like this:
So, as you can see I would like all the cells in between to be filled out with the same value as the two corner cells.
Any help is very much appreciated! Thanks in advance.
you could use SpecialCells() method of Range object:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Place this in a new module and run test_DTodor:
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, j).Value
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
In the each cell in a column I have this information in the cells:
A1 values:
Depth=standard;Size=1 section;Doors=hinged solid;Interior configuration=shelves;Compressor HP=1/2 HP;Interior finish=stainless steel;Exterior finish=stainless steel;Refrigeration=top mount self-contained
A2 values:
Top openings= 6 pan;Size=1 section;Compressor HP=1/6 HP;Style=drawers;Exterior finish=stainless steel;Interior finish=stainless steel;Refrigeration=rear mounted
A3,A4,A5 etc all follow similar formats
I need some method of abstracting out the following information into its own cells:
I need each semicolon separated value to be checked if there is a column name for it already, if not, make a new column and put all corresponding values where they need to be
I thought about using text->columns and then using index/match but I haven't been able to get my match criteria to work correctly. Was going to do this for each unique column. Or do I need to use VBA?
You could go with something like this, though you'll have to update the sheet name and probably where you want the final data located.
Sub SplitCell()
Dim DataFromCell, FoundCell
Dim Testing, Counted, LastCol
For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
Testing = Split(c.Value, ";")
Range("B" & c.row + 1).Value = "A" & c.row
Counted = UBound(Testing)
For Each x In Testing
DataFromCell = Split(x, "=")
With Sheet2
Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
MatchCase:=False, searchformat:=False)
End With
If Not FoundCell Is Nothing Then
Cells(c.row + 1, FoundCell.Column).Value = DataFromCell(1)
End If
If FoundCell Is Nothing Then
LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
Cells(1, LastCol + 1).Value = DataFromCell(0)
Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
End If
Next x
Next c
End Sub
Edit
Since the above was giving you errors you could try this one:
Sub SplitCell()
Dim DataFromCell, FoundCell
Dim Testing, Counted, LastCol
For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
Testing = Split(c.Value, ";")
Range("B" & c.row + 1).Value = "A" & c.row
Counted = UBound(Testing)
For Each x In Testing
DataFromCell = Split(x, "=")
LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
With Sheet2
FoundCell = Application.Match(DataFromCell(0), Range(Cells(1, 2), Cells(1, LastCol)), 0)
'Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
MatchCase:=False, searchformat:=False)
End With
If Not IsError(FoundCell) Then
Cells(c.row + 1, FoundCell + 1).Value = DataFromCell(1)
End If
If IsError(FoundCell) Then
Cells(1, LastCol + 1).Value = DataFromCell(0)
Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
End If
Next x
Next c
End Sub
Only changed a few things so that it is using Match instead of Find
My solution below works as intended but the data wasn't as formatted as I originally thought.
Option Explicit
Private Sub Auto_Open()
MsgBox ("Welcome to the delimiter file set.")
End Sub
'What this program does:
'http://i.imgur.com/7MVuZLt.png
Sub DelimitFilter()
Dim curSpec As String
Dim curSpecArray() As String
Dim i As Integer, IntColCounter As Integer, iCounter As Integer, argCounter As Integer
Dim WrdString0 As String, WrdString1 As String
Dim dblColNo As Double, dblRowNo As Double
Worksheets(1).Activate
'Reference to cell values that always have data associated to them
Range("W2").Activate
'checks for number of arguments to iterate through later
Do
If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate
argCounter = argCounter + 1
Loop
'Check # of arguments
Debug.Print (argCounter)
'Values to delimit
Range("X2").Activate
IntColCounter = 1
'Loop each row argument
For iCounter = 0 To argCounter
'Set var to activecell name
dblColNo = ActiveCell.Column
dblRowNo = ActiveCell.Row
'Grab input at active cell
curSpecArray() = Split(ActiveCell.Value, ";")
'Ignore empty rows
If Not IsEmpty(curSpecArray) Then
'Iterate every delimited active cell value at that row
For i = LBound(curSpecArray) To UBound(curSpecArray)
'Checks for unique attribute name, if none exists, make one
WrdString0 = Split(curSpecArray(i), "=")(0)
'a large range X1:ZZ1 is used as there are many unique column names
If IsError(Application.Match(WrdString0, Range("X1:ZZ1"), 0)) Then 'if NOT checks if value exists
Cells(1, dblColNo + IntColCounter).Value = WrdString0
IntColCounter = IntColCounter + 1
End If
'Output attribute value to matching row and column
WrdString1 = Trim(Split(curSpecArray(i), "=")(1))
Debug.Print (WrdString1)
Cells(dblRowNo, -1 + dblColNo + Application.Match(WrdString0, Range("X1:ZZ1"), 0)).Value = WrdString1
Next i
End If
'Iterate Next row value
ActiveCell.Offset(1, 0).Activate
Next iCounter
End Sub
I'm searching for the column name but my code is not working. This is what I have tried :
word = "sample"
Set aCell = ActiveSheet.Rows(1).Find(What:=word, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
lastRow = Cells(1, Columns.count).End(xlToLeft).Column
For k = 0 To lastRow
If aCell Is Nothing Then
aCell.Offset(0, 1).EntireColumn.Delete
End If
Next k
All I want to do is to delete the entire column if it is found. Any help ?
You could do it this way:
Sub deleteColumn()
Dim headerColumnToDelete As String
Dim endRow As Integer
Dim counter As Integer
endRow = Cells(1, Columns.Count).End(xlToLeft).Column
headerColumnToDelete = "sample"
For counter = endRow To 1 Step -1
If Cells(1, counter) = headerColumnToDelete Then
Cells(1, counter).EntireColumn.Delete
End If
Next counter
End Sub
If you want to delete the whole column with the column heading "sample", try this in a Module:
Public Sub DeleteSample()
DeleteColumn ("sample")
End Sub
Public Sub DeleteColumn(Name As String)
'Get the header row
Dim row As Range
Set row = Rows(1)
'Find the cell containing Name in that row
Dim result As Range
Set result = row.Find(Name)
Dim wholeColumn As Range
'Select the whole column (or quit if it's not found)
On Error GoTo Catch
Set wholeColumn = result.EntireColumn()
On Error GoTo 0
'Delete the whole column and shift cells left
wholeColumn.Delete xlShiftToLeft
Catch:
Exit Sub
End Sub
You don't need a For-loop at all, you can just use the Excel API to find the cell :)
Sub columndelete()
Dim lastcolumn As Long
word = "sample"
lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lastcolumn
If Cells(1, i).Value = word Then
Cells(1, i).EntireColumn.Delete
End If
Next i
End Sub
Just made some changes in your code:
Sub test()
word = "sample"
Set acell = ActiveSheet.Rows(1).Find(What:=word, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not (acell Is Nothing) Then
acell.EntireColumn.Delete
End If
End Sub
I wrote an Excel macro and it seems to work fine. It displays an inputbox and once I give the value in it. It saves that value into first cell of column C (C1). However the second time I run macro I want it to be written into C2 and keep all datas in different rows in column C but each time, it writes it into C1 and cause a data loss.
Sub DataInput()
Dim SearchTarget As String
Dim myRow As Long
Dim Rng As Range
Static PrevCell As Range
Dim FoundCell As Range
Dim CurCell As Range
Dim a As String
Dim Target As Range
'SearchTarget = "asdf"
SearchTarget = InputBox("Scan or type product barcode...", "New State Entry")
If PrevCell Is Nothing Then
myRow = Selection.Row
Set PrevCell = Range("C" & myRow)
End If
'Set Rng = Range("C:C,E:E") 'Columns for search defined here
Set Rng = Range("C:C,C:C") 'Columns for search defined here
With Rng
Set FoundCell = .Cells.Find(What:=SearchTarget, _
After:=PrevCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)
End With
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Range("C1").Value = InputBox("code?")
Range("D1").Value = Now()
Else
FoundCell.Activate
' If PrevCell.Address = FoundCell.Address Then
' MsgBox "there's only one!"
' End If
ActiveCell.Offset(0, 1).Select
timestamp = Format(Now(), "dd-mmm-yy hh:mm")
ActiveCell = timestamp
ActiveCell = Now()
ActiveCell.Offset(0, 2).Select
ActiveCell = "T141000"
ActiveCell.Offset(0, 1).Select
Set PrevCell = FoundCell
End If
End Sub
The problem here lies in your if statement - you are always storing the newly entered codes in cells C1 and the date in D1. You need to dynamically work out the next available row number and use that instead. Try something like this:
Public Sub DataInput()
...
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Dim nextFreeRow As Integer
nextFreeRow = Range("C" & Rows.Count).End(xlUp).Row + 1
Range("C" & nextFreeRow).Value = InputBox("code?")
Range("D" & nextFreeRow).Value = Now()
Else
...
End If
...
End Sub