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
Related
I am trying to copy data from one worksheet to another based on the column-name. In the source worksheet, the data starts at A1. In the destination worksheet, the data should be pasted at row A11 and not A1. If I used EntireColumn.Copy I get an error about the source and destination copy area not being the same. I came across the UsedRange property but I am unbale to apply it to my scenario
For Each columnName In allColumns
'call a function to get the column to copy
If columnToCopy > 0 Then
columnName.Offset(1, 0).EntireColumn.Copy Destination:=ws2.Cells(11, columnToCopy)
End If
Next
In the above snippet, In dont want to use 'EntireColumn'. I only want the columns that have data. The variable columnName is for example 'Person ID'
What is the best way to do this?
Thanks.
This would be a typical approach:
For Each ColumnName In allColumns
If columnToCopy > 0 Then
With ColumnName.Parent
.Range(ColumnName.Offset(1, 0), .Cells(.Rows.Count, ColumnName.Column).End(xlUp)).Copy _
Destination:=ws2.Cells(11, columnToCopy)
End With
End If
Next
Assumes allColumns is a collection of single-cell ranges/column headers.
Copy/Paste Column
There is not enough information to give an accurate answer so here is a scenario you might consider studying.
The Code
Option Explicit
Sub TESTdetermineColumnNumber()
' Define constants. Should be more.
' Define Criteria.
Const Criteria As String = "Total"
' Define Header Row.
Const hRow As Long = 1
' Define Copy Range (Column Range)
' Define Source Worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' Define Header Row Range.
Dim RowRange As Range
Set RowRange = ws.Rows(hRow)
' Determine Column Number.
Dim ColumnNumber As Long
ColumnNumber = determineColumnNumber(RowRange, Criteria)
' Validate Column Number.
If ColumnNumber = 0 Then
Exit Sub
End If
' Determine Last Row.
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, ColumnNumber).End(xlUp).Row
' Define First Data Row Number.
Dim FirstRow As Long
FirstRow = hRow + 1
' Define Column Range.
Dim ColumnRange As Range
Set ColumnRange = ws.Cells(FirstRow, ColumnNumber) _
.Resize(LastRow - FirstRow + 1)
' Define Paste Range.
' Define Destination Worksheet.
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
' Define Destination Column.
Dim columnToCopy As Long
columnToCopy = 2
' Define Paste Range.
Dim PasteRange As Range
Set PasteRange = ws2.Cells(11, columnToCopy)
' Copy/Paste.
' Copy values, formulas and formats.
ColumnRange.Copy Destination:=PasteRange
' It is more efficient if you need only values to use the following:
PasteRange.Resize(ColumnRange.Rows.Count).Value = ColumnRange.Value
End Sub
Function determineColumnNumber(RowRange As Range, _
Criteria As String) _
As Long
Dim Temp As Variant
Temp = Application.Match(Criteria, RowRange, 0)
If Not IsError(Temp) Then
determineColumnNumber = Temp
End If
End Function
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
We have two worksheets.
Source worksheet is "profes"
Target worksheet is "primaria"
The data common to both worksheets is the name column.
ie: David Smith Weston appears in both worksheets.
We need to "lookup" each students name and paste values from "profes" to "primaria". I have most of the code working already BUT I don't know how to add the "lookup" part. As you can see it's wrong.
Sub Button1_Click()
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N5:R1000") ' Do 100 rows
**If Source.Cells(j, "C").Value = Target.Cells(j, "A").Value** Then
Target.Cells(j, "N").Value = Source.Cells(j, "D").Value
j = j + 1
End If
Next c
End Sub
When comparing 2 ranges between 2 worksheets, you have 1 For loop, and replace the second loop with the Match function.
Once you loop over your "profes" sheet's range, and per cell you check if that value is found within the second range in "primaria" sheet, I used LookupRng, as you can see in the code below - you will need to adjust the range cording to your needs.
Code
Option Explicit
Sub Button1_Click()
Dim Source As Worksheet, Target As Worksheet
Dim MatchRow As Variant
Dim j As Long
Dim C As Range, LookupRng As Range
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
' set up the Lookup range in "primaria" sheet , this is just an example, modify according to your needs
Set LookupRng = Target.Range("A2:A100")
For Each C In Source.Range("N5:R1000") ' Do 100 rows
If Not IsError(Application.Match(C.Value, LookupRng, 0)) Then ' Match was successfull
MatchRow = Application.Match(C.Value, LookupRng, 0) ' get the row number from "primaria" sheet where match was found
Target.Cells(C.Row, "N").Value = Source.Cells(MatchRow, "D").Value
End If
Next C
End Sub
Use the worksheet's MATCH function to locate names from the source column C in the target's column A.
Your supplied code is hard to decipher but perhaps this is closer to what you want to accomplish.
Sub Button1_Click()
dim j as long, r as variant
dim source as worksheet, target as worksheet
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
with source
for j = 5 to .cells(.rows.count, "C").end(xlup).row
r=application.match(.cells(j, "C").value2, target.columns("A"), 0)
if not iserror(r) then
target(r, "D").resize(1, 5) = .cells(j, "N").resize(1, 5).value
end if
next j
end with
End Sub
I need the row/column combinations marked with an 'X' in my table to be available as three columns in another sheet.
The first column will consist of the cell address,
the second column will have the Row Name, and
the third column will have the Column name of the marked cells.
VLookUp and Index/Match are not helping.
Expected result:
You might get away with something as lazy as, you would change the sheets and the target range srcSht.Range("A1:C5") as appropriate:
Option Explicit
Sub test()
Dim wb As Workbook
Dim srcSht As Worksheet
Dim destSht As Worksheet
Set wb = ThisWorkbook
Set srcSht = wb.Sheets("Sheet1")
Set destSht = wb.Sheets("Sheet2")
Dim targetRange As Range
Set targetRange = srcSht.Range("A1:C5")
Dim loopArray()
loopArray = targetRange.Value2
Dim currRow As Long
Dim currCol As Long
Dim counter As Long
For currRow = LBound(loopArray, 1) To UBound(loopArray, 1)
For currCol = LBound(loopArray, 2) To UBound(loopArray, 2)
If LCase$(loopArray(currRow, currCol) )= "x" Then
counter = counter + 1
destSht.Cells(counter, 1) = targetRange.Cells(currRow, currCol).Address
destSht.Cells(counter, 2) = "Column " & targetRange.Cells(currRow, currCol).Column
destSht.Cells(counter, 3) = "Row " & targetRange.Cells(currRow, currCol).Row
End If
Next currCol
Next currRow
End Sub
This array formula seems to be working for me
=IFERROR(ADDRESS(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW())/100,MOD(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW()),100)),"")
but I think could be done more tidily with AGGREGATE.
Also there's no particular reason for multiplying by 100, multiplying by the exact number of columns in the array plus 1 would be better.
Here it is with AGGREGATE
=IFERROR(ADDRESS(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW())/100,MOD(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW()),100)),"")
EDIT
Here is a more general solution for a 2d range of any size anywhere on the sheet.
For the row:
=IFERROR(INDEX($A$2:$A$7,AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+1),"")
For the column:
=IFERROR(INDEX($B$1:$D$1,MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+1),"")
For the cell address:
=IFERROR(ADDRESS(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+ROW($B$2),
MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+COLUMN($B$2)),"")
Here's a similar way to get a similar result:
Sub listCells()
Dim rIn As Range, c As Range, rOut As Range
Set rIn = Sheets("Sheet1").Range("B2:D7") 'input range
Set rOut = Sheets("Sheet1").Range("F1") 'first cell for output
For Each c In rIn
If c <> "" Then 'not blank so populate output
Range(rOut, rOut.Offset(, 2)) = Array(c.Address, c.Column - 1, c.Row - 1)
Set rOut = rOut.Offset(1, 0) 'next row
End If
Next c
End Sub
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