So I've already had this piece of code tweaked on here for another reason. Searching through List Object Table's Column in For Loop
Essentially the issue at hand boils down to the fact that I want to loop through a table, and if a row meets certain criteria I want to copy the value over to a new tab (for later use.)
I've done this before by using a variable called RowToPastteTo to get to the next empty row and have followed the same structure as before, but or some reason all of the code runs without a debugging issue, but just doesn't copy the values over.
Here is the full code
Sub RequestedAssetList()
Dim FullAssLi As ListObject, RowRange As ListRow 'Defining the Table and Range
Set FullAssLi = ThisWorkbook.Sheets("Asset List").ListObjects("AssListTab") 'Set FullAsset Lists as the Asset Table
With ThisWorkbook 'Within the workbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assets" 'Adds a sheet at the end of the workbook called Assets
End With
With ThisWorkbook.Sheets("Assets")
Dim RowToPasteTo As Long
'RowToPasteTo = ThisWorkbook.Worksheets("Assets").Range("A1").End(xlDown).Row + 1
RowToPasteTo = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 'Sets variable as the next exmpy row on column A of Assets' tab
For Each RowRange In FullAssLi.ListRows
If RowRange.Range.Cells(9).Value = UserForm2.SourceLiBo.Value Then 'If Data Source matches userform criteria then
ThisWorkbook.Sheets("Assets").Range("A1").Value = RowRange.Range.Cells(2).Value
'
''
End If
Next
End With
End Sub
It seems that the problem line is If RowRange.Range.Cells(9).Value = UserForm2.SourceLiBo.Value Then
ThisWorkbook.Sheets("Assets").Range("A1").Value = RowRange.Range.Cells(2).Value
How can I get this to copy the figures from the FullAssL into the new Assets sheet?
I've played around, changing that line of code to changing the back ground colour of RowRange.Cells(9) and still nothing.
Your code has no errors, indeed. By the way, if i'm well thinking, you are pasting the value at the same cell ever. If you want a list of values, you have to increment your row reference like:
Dim i
i = 1
For Each RowRange In FullAssLi.ListRows
If RowRange.Range.Cells(9).Value = UserForm2.SourceLiBo.Value Then
ThisWorkbook.Sheets("Assets").Range("A" & i).Value = RowRange.Range.Cells(2).Value
i = i + 1
End If
Next
Related
I'm trying to create a VBA script that goes into file1 and copies the data into file2. File 1 contains the data.
The issue I'm having is file2 has more columns and not necessarily in the same order as the ones in file1. As well, the Range is wrong, I'm not sure how to select all relevant data. How do i make sure it gets all the relevant rows per column in file1?
Sub GetDatacClosedBook()
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\Data\Documents\File1", True, True)
Set wbOpen = ActiveWorkbook
'this is the workbook in which the data will be transferred to
Workbooks.Open "C:\Users\Data\Documents\file2.xlsx"
Worksheets("Sheet1").Range("A1:D3").Formula = src.Worksheets("Sheet1").Range("A1:D3").Formula
wbOpen.Close
End Sub
You should first figure out the columns in your data sheet match which columns in your destination sheet. And then everything should be easy. This can be done in multiple way. I assume your A row has the headers, then you can match the column by match the headers
Sub Macro()
Dim destSht As Worksheet, srcSht As Worksheet
Dim src_ColCnt As Integer, dest_ColCnt As Integer
'Open the workbooks and grab the sheet reference, assign it to a worksheet variables
Set srcSht = Workbooks.Open("D:\data.xlsx").Sheets("Sheet1")
Set destSht = Workbooks.Open("D:\report.xlsx").Sheets("Sheet1")
'Find how many columns in your destination sheet, how many columns in your source sheet and how many rows the source sheet data has.
dest_ColCnt = destSht.Range("A1").End(xlToRight).Column
src_ColCnt = srcSht.Range("A1").End(xlToRight).Column
src_RCnt = srcSht.Range("A1").End(xlDown).Row - 1
'The code below is basically loop over the source sheet headers, and for each header
'find the column in your destination that has the same header
'And then assign the data row by row once it knows which column in the data sheet go to which column in the destination sheet
For i = 1 To src_ColCnt
Header = srcSht.Cells(1, i)
For j = 1 To dest_ColCnt
If destSht.Cells(1, j).Value = Header Then
For r = 1 To src_RCnt
'Do your assignment here row by row
'You can assign formula, value or different thing based on your requirement
'I assume your data start from the second row here
destSht.Cells(r + 1, j).Value = srcSht.Cells(r + 1, i).Value
Next r
End If
Next j
Next i
End Sub
This is not elegant but should give you the idea. To make the above more elegant, There are a couple of things you can use. One, using Scripting.Dictionary data structure to hold the headers in the dictionary as key, the column ordinal as the value. And then you loop your destination sheet column by column. Retrieve the right column ordinal from the dictionary. Two, you can use WorksheetFunctions.Match() to find the ordinal. Or even better if you know the order by yourself. You can just hard coding an order Array, like mapOrder = Array(3,1,5,6) and just use this array to match the column.
You could write a function that points to a specific workbook, locates a column -perhaps by heading- and captures that columns data into an Array which is returned by the function.
Then write the arrays in the desired order to the other sheet.
Example for the Subroutine and the function:
Private Sub GetDatacClosedBook()
Dim ExampleArray As Variant
Dim Destination As Range
ExampleArray = LocateColumnReturnArray(ThisWorkbook.Sheets("Sheet1"), "Value to find in row1 of the desired column")
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A1")
Destination.Resize(UBound(ExampleArray), 1) = ExampleArray
End Sub
Public Function LocateColumnReturnArray(ByRef TargetWorksheet As Worksheet, ByVal TargetColumnHeader As String) As Variant
Dim LastUsedColumn As Long
Dim TargetCell As Range
With TargetWorksheet
LastUsedColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each TargetCell In .Range(.Cells(1, 1), .Cells(1, LastUsedColumn))
If TargetCell.Value = TargetColumnHeader Then
LastUsedRow = .Cells(.Rows.Count, LastUsedColumn).End(xlUp).Row
LocateColumnReturnArray = .Range(.Cells(2, TargetCell.Column), .Cells(LastUsedRow, TargetCell.Column))
Exit Function
End If
Next TargetCell
End With
End Function
You can take this concept and apply it to your requirements.
This function could be run as many times as required for each column you want the data for.
You would need to also specify the target for each column of data but you could modify the above to use a loop based on the columns your data is being written to.
So in the simplest explanation; I want to search through my ListObjecttable of data (specifically column 9) and copy values to another sheet if they match a criteria (ignore this bit for now).
Currently my code sets out the table as a list object but doesn't specify the column due to the fact I'll be using multiple columns.
When I go to loop through the ninth column though it provides me a runtime error 9. Am I referring to the column incorrectly?
Sub RequestedAssetList()
Dim FullAssLi As ListObject, RowToPasteTo As Long 'Defining the Table and Range
Set FullAssLi = ThisWorkbook.Sheets("Asset List").ListObjects("AssListTab") 'Set FullAsset Lists as the Asset Table
With ThisWorkbook 'Within the workbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assets" 'Adds a sheet at the end of the workbook called Assets
End With
With ThisWorkbook.Sheets("Assets")
RowToPasteTo = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 'Sets variable as the next exmpy row on column A of Assets' tab
For i = 1 To ThisWorkbook.Sheets("Asset List").ListObjects("AssListTab").Range.Rows.Count 'For first interger to last row in table
If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then
End If
Next i
End With
End Sub
Is the line If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then incorrect?
EDIT: The userform is bringing through a value set in the code run before.
You are refering to the full column all the time:
If FullAssLi.ListColumns(9).Value = UserForm2.SourceLiBo.Value Then
Instead try something like:
Dim LRow as ListRow
For Each LRow In FullAssLi.ListRows
If LRow.Range.Cells(9).Value = UserForm2.SourceLiBo.Value Then
End If
Next
I have an Excel file which has a Summary tab at the start, followed by several tabs which contain weekly information. As the weeks progress, I may add additional rows to the weekly sheet, meaning that the total is not always in the same cell on each sheet.
I am looking for a formula that will search a specified weekly sheet for the words "Grand Total" and return it's address, which I can then build into other formulas, so that the Summary sheet will populate the correct values regardless of whether additional rows have been added.
Hi, your question should always contain your current efforts and ideally some code as well. But given it's a fairly basic question to answer and you're new here I decided to answer it
With that aside...:
Option Explicit
Private Function get_total () As Range
Dim ws As Worksheet: Set ws = Sheets("Your Sheet Name") 'set your own
Dim lc as Long
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
' determines last column with data
'some other useful variables
Dim lr as Long 'last row
Dim temp as Range 'find result
Dim i as Long ' loop index
For i = 1 to lc
lr = ws.Cells(Rows.Count, i).End(xlUp).Row
Set temp = ws.Range(Cells(1, i), Cells(lr, i)).Find("Grand Total", lookin:=xlValues)
If Not temp Is Nothing Then 'if we found grand total, return it
Set get_total = temp 'return range of result
End If
Next i
Exit Function 'if no Range found, exit function ("return;")
End Function
Technically, that alone is the answer, but for practical use, you might want to visualize it
So with this function you will loop through all the columns and it will stop upon Grand Total is found, or alternatively will "return" void if not found any
Obviously, this only is a function, so if you wanted to print out the result, you could create a procedure like this:
Private Sub print_grand_total()
Dim res as Range
Set res = get_total
If Not res Is Nothing Then
MsgBox("Found in Cell[" & res.row & "," & res.Column & "]")
Else
MsgBox("Grand Total not found!")
End If
End Sub
So, I've set an example sheet:
After running the procedure, it returns the result, successfully:
Note: Small implementation foresight: This will not work in cases, where the first row is empty (because it can't detect last column properly then). Edit the lc code depending on where your data range begins
Thank you all for helping with my earlier query. I have included my next obstacle as a separate thread and hope that doesn't violate any rules/etiquette.
I now have a search facility that creates a list of potentially relevant diagnoses:
What I'd like to be able to do is work down the list of potentially relevant diagnoses and manually eliminate those that are not relevant by placing a "x" in the adjacent cell. I would then like to press a button and for all checked diagnoses to be appended to a list on another sheet (titled "List"):
In an ideal world, repeating the search/select/button process would then simply append new diagnoses to the same list, i.e. identify the next blank cell in a column on "List" and carry on from there. One potential difficulty is that I need to copy the diagnosis text out of each cell rather than the formula that's actually there.
Gary's Student has answered a similar query previously with this script but it doesn't quite get me far enough as it takes data from a single cell and doesn't distinguish between text/formulae:
Sub ButtonCode()
Dim N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(N, "A").Value = Range("C3").Value
End Sub
Can anyone help?
You may want to try something like I've provided below. Notice that you can grab the cells that you specify by the all the 'x' checkmarks by using the .Offset property. Code below:
Sub move_diagnoses()
Dim diagnosesheet As Worksheet
Dim copysheet As Worksheet
Dim last_diagnosis_row As Integer
Dim last_list_row As Integer
Dim loserange As Range
Dim losecell As Range
'Set your worksheets first
Set diagnosesheet = Worksheets("Diagnoses")
'I titled the worksheet you have the diagnoses on as 'Diagnoses' since you didn't specify
Set copysheet = Worksheets("List")
'Now set the range (i.e. collection of cells) that enumerate all the potential diagnoses
'First find the last row in the diagnoses column
'Then find the last used row in the 'List' worksheet
last_diagnosis_row = diagnosesheet.Range("E" & Rows.Count).End(xlUp).Row
last_list_row = diagnosesheet.Range("A" & Rows.Count).End(xlUp).Row
Set loserange = diagnosesheet.Range("D2:D" & last_diagnosis_row)
'Notice the loserange (i.e. the range that contains the all the checkmarks is defined from D2 onwards
For Each losecell In loserange.Cells
If Trim(losecell.Value) = "x" Then
copysheet.Cells(last_list_row, 1).Value = losecell.Offset(0, 1).Text
copysheet.Cells(last_list_row, 2).Value = losecell.Offset(0, 2).Text
last_list_row = last_list_row + 1
End If
Next losecell
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.