The following piece of code works great for me except that it stops when it gets an empty row in the column.
I would like to modify it by determining to copy-paste until the last row in column A. I have made a LASTROW variable, but I can not figure out where to use it exactly.
LASTROW = Range("A" & Rows.Count).End(xlUp).Row
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
Thank you in advance !
Have you tryed this way?
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0).Address, Worksheets("ws1").Cells(Rows.Count, header.Column).End(xlUp).Address).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
Related
I've a data where I applied filter to the column based on its header. Now I want to make some changes to filtered data i.e. visible cells in the same column. I've below mentioned code where filter has been applied to column with header "Query Type" & it's column letter is "E". Is it possible to put offset based on the column header instead of column letter? Because column gets changing everytime. In below example, how E2 or E can be replaced dynamically to accommodate column with header? I tried replacing "E" with FiltCol; however it is not working.
Sub Filter()
Dim FiltCol As Variant
FiltCol = Rows("1:1").Find(What:="Query Type", LookAt:=xlWhole).Column
ActiveSheet.UsedRange.AutoFilter Field:=FiltCol, Criteria1:="Rejected"
ActiveSheet.Range("E2", Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "Accepted"
End Sub
When you want to deal with column numbers, you can use the .Cells-property of the worksheet. Cells expects 2 parameters, row and column. The row is always a (long) number, the column can be specified as number or with the column character(s)
The following terms are all the same:
ActiveSheet.Range("D3")
ActiveSheet.Cells(3, 4)
ActiveSheet.Cells(3, "D")
Your code could look like
Sub Filter()
Dim FiltCol As Variant
With ActiveSheet
FiltCol = .Rows("1:1").Find(What:="Query Type", LookAt:=xlWhole).Column
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, FiltCol).End(xlUp).row
.UsedRange.AutoFilter Field:=FiltCol, Criteria1:="Rejected"
Dim visibleCells As Range
On Error Resume Next ' Avoid runtime error if nothing is found
Set visibleCells = .Range(.Cells(2, FiltCol), .Cells(lastRow, FiltCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not visibleCells Is Nothing Then
visibleCells.Value2 = "Accepted"
End If
End With
End Sub
cells(1,1).offset(2,3)
will get you from A1 to D3
lastRow = Cells(105000, FiltCol).End(xlUp).Row <<< This is poor, see edit below
ActiveSheet.Range(Cells(2, FiltCol).Offset(0, 1), Cells(lastRow, FiltCol).Offset(0, 1)).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "Accepted"
edit:
Better to dynamically describe the last row
lastRow = Cells(Cells.Rows.Count, FiltCol).End(xlUp).Row
I am trying to create something that is capable of taking the value from one text box, searching a group of column headers to find the correct one, and then placing a new value from a second text box into the last row under that column. I adapted this code that I found on here, https://stackoverflow.com/a/37687346/13073514, but I need some help. This code posts the value from the second text box under every header, and I would like it to only post it under the header that is found in textbox 1. Can anyone help me and explain how I can make this work? I am new to vba, so any explanations would be greatly appreciated.
Public Sub FindAndConvert()
Dim i As Integer
Dim lastRow As Long
Dim myRng As Range
Dim mycell As Range
Dim MyColl As Collection
Dim myIterator As Variant
Set MyColl = New Collection
MyColl.Add "Craig"
MyColl.Add "Ed"
lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 1 To 25
For Each myIterator In MyColl
If Cells(1, i) = myIterator Then
Set myRng = Range(Cells(2, i), Cells(lastRow, i))
For Each mycell In myRng
mycell.Value = Val(mycell.Value)
Next
End If
Next
Next
End Sub
Basic example:
Sub tester()
AddUnderHeader txtHeader.Text, txtContent.Text
End Sub
'Find header 'theHeader' in row1 and add value 'theValue' below it,
' in the first empty cell
Sub AddUnderHeader(theHeader, theValue)
Dim m
With ThisWorkbook.Sheets("Data")
m = Application.Match(theHeader, .Rows(1), 0)
If Not IsError(m) Then
'got a match: m = column number
.Cells(.Rows.Count, m).End(xlUp).Offset(1, 0).Value = theValue
Else
'no match - warn user
MsgBox "Header '" & theHeader & "' not found!", vbExclamation
End If
End With
End Sub
I have commented your code for your better understanding. Here it is.
Public Sub FindAndConvert()
Dim i As Integer
Dim lastRow As Long
Dim myRng As Range
Dim myCell As Range
Dim MyColl As Collection
Dim myIterator As Variant
Set MyColl = New Collection
MyColl.Add "Craig"
MyColl.Add "Ed"
Debug.Print MyColl(1), MyColl(2) ' see output in the Immediate Window
' your code starts in the top left corner of the sheet,
' moves backward (xlPrevious) from there by rows (xlByRows) until
' it finds the first non-empty cell and returns its row number.
' This cell is likely to be in column A.
lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 1 To 25 ' do the following 25 times
' in Cells(1, i), i represents a column number.
' 1 is the row. It never changes.
' Therefore the code will look at A1, B1, C1 .. until Y1 = cells(1, 25)
For Each myIterator In MyColl ' take each item in MyColl in turn
If Cells(1, i) = myIterator Then
' set a range in the column defined by the current value of i
' extend it from row 2 to the lastRow
Set myRng = Range(Cells(2, i), Cells(lastRow, i))
' loop through all the cells in myRng
For Each myCell In myRng
' convert the value found in each cell to a number.
' in this process any non-numeric cells would become zero.
myCell.Value = Val(myCell.Value)
Next myCell
End If
Next myIterator
Next i
End Sub
As you see, there is no TextBox involved anywhere. Therefore your question can't be readily understood. However, my explanations may enable you to modify it nevertheless. It's all a question of identifying cells in the worksheet by their coordinates and assigning the correct value to them.
Edit/Preamble
Sorry, didn't read that you want to use TextBoxes and to collect data one by one instead of applying a procedure to a whole data range.
Nevertheless I don't remove the following code, as some readers might find my approach helpful or want to study a rather unknown use of the Application.Match() function :)
Find all header columns via single Match()
This (late) approach assumes a two-column data range (header-id and connected value).
It demonstrates a method how to find all existant header columns by executing a single Application.Match() in a â–ºone liner ~> see step [3].
Additional feature: If there are ids that can't be found in existant headers the ItemCols array receives an Error items; step [4] checks possible error items adding these values to the last column.
The other steps use help functions as listed below.
[1] getDataRange() gets range data assigning them to variant data array
[2] HeaderSheet() get headers as 1-based "flat" array and sets target sheet
[3] see explanation above
[4] nxtRow() gets next free row in target sheet before writing to found column
Example call
Sub AddDataToHeaderColumn()
'[1] get range data assigning them to variant data array
Dim rng As Range, data
Set rng = getDataRange(Sheet1, data) ' << change to data sheet's Code(Name)
'[2] get headers as 1-based "flat" array
Dim targetSheet As Worksheet, headers
Set targetSheet = HeaderSheet(Sheet2, headers)
'[3] match header column numbers (writing results to array ItemCols as one liner)
Dim ids: ids = Application.Transpose(Application.Index(data, 0, 1))
Dim ItemCols: ItemCols = Application.Match(ids, Array(headers), 0)
'[4] write data to found column number col
Dim i As Long, col As Long
For i = 1 To UBound(ItemCols)
'a) get column number (or get last header column if not found)
col = IIf(IsError(ItemCols(i)), UBound(headers), ItemCols(i))
'b) write to target cells in found columns
targetSheet.Cells(nxtRow(targetSheet, col), col) = data(i, 2)
Next i
End Sub
Help functions
I transferred parts of the main procedure to some function calls for better readibility and as possible help to users by demonstrating some implicit ByRef arguments such as [ByRef]mySheet or passing an empty array such as data or headers.
'[1]
Function getDataRange(mySheet As Worksheet, data) As Range
'Purpose: assign current column A:B values to referenced data array
'Note: edit/corrected assumed data range in columns A:B
With mySheet
Set getDataRange = .Range("A2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
data = getDataRange ' assign range data to referenced data array
End With
End Function
'[2]
Function HeaderSheet(mySheet As Worksheet, headers) As Worksheet
'Purpose: assign titles to referenced headers array and return worksheet reference
'Note: assumes titles in row 1
With mySheet
Dim lastCol As Long: lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
headers = Application.Transpose(Application.Transpose(.Range("A1").Resize(1, lastCol)))
End With
Set HeaderSheet = mySheet
End Function
'[4]
Function nxtRow(mySheet As Worksheet, ByVal currCol As Long) As Long
'Purpose: get next empty row in currently found header column
With mySheet
nxtRow = .Cells(.Rows.Count, currCol).End(xlUp).Row + 1
End With
End Function
I have two columns of data I am cleaning up using VBA. If the value in column A is non-numeric or blank, I need to delete the entire row. Below is a sample of the data and the code I am trying to use. It seems to be completely skipping over the portion of the code that deletes the rows if IsNumeric returns false.
9669 DONE
9670 OPEN
Order # STATUS
9552
9672
Code that isn't working.
Dim cell As Range
For Each cell In Range("A1:A" & max_col)
If IsNumeric(cell) = False Then
Cells(cell, 1).Select
Rows(cell).EntireRow.Delete
Exit For
End If
Next cell
Any help is appreciated!
use just
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
End With
or, if you don't know for sure whether there will be empty or not numeric cells
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
If WorksheetFunction.Count(.Cells) < .Rows.Count Then .SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
End With
Loop from the bottom
Dim max_col as long
max_col = 100
Dim i as Long
For i = max_col to 1 step -1
If Not isnumeric(activesheet.cells(i,1)) then
activesheet.rows(i).delete
End If
Next i
When deleting (or adding, for that matter) rows you need to loop backwards through the data set - See #ScottCraner's example for an exact answer like that - or, you create the range of cells to delete then delete at once, like below:
Dim rowNo as Long
For rowNo = 1 to max_col
Dim cell as Range
Set cell = Range(rowNo,1)
If IsNumeric(cell) Then
Dim collectRows as Range
If collectRows is Nothing Then
Set collectRows = cell
Else
Set collectRows = Union(collectRows,cell)
End If
End If
Next
collectRows.EntireRow.Delete
I'm sure this will be a quick one for someone. I've found some VBA code that does what I want, I just want it to reference the last row as the last row in column A rather than whatever column it is looking at at that time.
Below is the original code.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("FPS").Range("A1:BK1") '
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xldown)).Copy Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
And this was my attempt.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Dim LastRow As Long
Set headers = Worksheets("FPS").Range("A1:BK1") '
rowlast = Worksheets("FPS").Cells(Rows.Count, "A").End(xlUp).Row
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
With Worksheets("FPS")
.Range(.Cells(header.Row + 1, header.Column), .Cells(rowlast, headercolumn)).Copy Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End With
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("TempTable").Range("A1:Y1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
I feel like I've got the right idea but just don't know how to implement it. Any help and an explanation would be much appreciated as I am very keen to learn.
Thanks in advance
Declare all variables.
Don't set a Long.
Assign the worksheet to ALL Range objects.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Dim rowlast As Long
Set headers = Worksheets("FPS").Range("A1:BK1") '
rowlast = Worksheets("FPS").Cells(Rows.Count, "A").End(xlUp).row
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
With Worksheets("FPS")
.Range(.Cells(header.row + 1, header.Column), .Cells(rowlast, headercolumn)).Copy _
Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End With
End If
Next
End Sub
AlexP provided the following code to a question about copying columns. It works great for me except that in ws1, the columns have equations that get copied over to ws2. I just want to copy over the values, not the equations.
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
Just split this line:
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
and use the .PasteSpecial() method instead
e.g.
Range(header.Offset(1, 0), header.End(xlDown)).Copy
Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value)).PasteSpecial(xlPasteValues)
Application.CutCopyMode = False