I reformatted a range of Sheets("Records") in a workbook as a Table (named "RecordsTable") to make it easier to do INDEX(MATCH,MATCH) functions for generating reports.... but now I screwed up my looping routine for filling that range from the input on Sheets("FORM").
It used to be:
Set r = Sheets("Records").Range(A & Rows.Count).End(x1Up).Offset(1, 0)
i = 0
For Each c In Range("dataRange")
'dataRange is a list of cells to reference from the FORM input sheet
r.Offset(0, i).Value = Worksheets("FORM").Range(c)
i = i + 1
Next
However this code is now selecting the first row at the END of "RecordsTable" (row 501, as I defined 500 rows in my table) and inserting the data there.
I tried to change it to this:
Set r = Sheets("Records").ListObjects("RecordsTable").DataBodyRange("A" & Rows.Count).End(x1Up).Offset(1, 0)
i = 0
For Each c In Range("dataRange")
r.Offset(0, i).Value = Worksheets("FORM").Range(c)
i = i + 1
Next
But this code is still selecting row 501 and making that row part of "RecordsTable".
How can I properly Set "r" to = the first empty row in "RecordsTable"?
For reference, Column "A" in "RecordsTable" has the header [INV #]. Also, when I step into the "Set r = ..." line, Rows.Count is returning a value of 1million+ (ie, total rows on the sheet) - if I understand this correctly, I want it to return a value of 500 (ie, total rows in table) - is that correct?
EDIT
"dataRange" is a single column list of cell references (I do have them labeled in column B, as #chrisneilsen suggest:
A
J6
Y6
J8
J10
Y8
etc.
They are the cells on Sheets("FORM") that I need to pull data from and populate into my table, in the order indicated in "dataRange".
Assuming you really have a Table, adding data to a Table (ListObject) using it's properties and methods:
Sub Demo()
Dim lo As ListObject
Dim c As Range
Set lo = Worksheets("Records").ListObjects("RecordsTable")
For Each c In Sheets("V").Range("dataRange")
If Not lo.InsertRowRange Is Nothing Then
lo.InsertRowRange.Cells(1, 1) = Sheets("FORM").Range(c)
Else
lo.ListRows.Add.Range.Cells(1, 1) = Sheets("FORM").Range(c)
End If
Next
End Sub
Note: looping a range on sheet V and using that as a pointer to data on sheet FORM, copied from your answer - I'm assuming you know what you are doing here
Based on OP comment, adding data a single new row
Sub Demo()
Dim lo As ListObject
Dim c As Range, TableRange As Range
Dim i As Long
Set lo = Worksheetsheets("Records").ListObjects("RecordsTable")
If Not lo.InsertRowRange Is Nothing Then
Set TableRange = lo.InsertRowRange
Else
Set TableRange = lo.ListRows.Add.Range
End If
i = 1
For Each c In Sheets("V").Range("dataRange")
TableRange.Cells(1, i) = Sheets("FORM").Range(c)
i = i + 1
Next
End Sub
Note, this assumes that the order of the table columns is the same as the order of dataRange. It may be better to include table field names in dataRange to avoid any mismatch issues
As mentioned in updated OP, if column labels are in the next column, replace the For loop with this (and add Dim r as Range, col as long to declarations)
For Each c In Sheets("V").Range("dataRange")
If Not c = vbNullString Then
Set r = Worksheets("FORM").Range(c.Value)
col = lo.ListColumns(c.Offset(, 1).Value).Index
TableRange.Cells(1, col) = r.Value
End If
Next
Related
I am relatively new to coding in general, but here goes:
I have a huge list of membershipdata which I am trying to organize. This is going to be done weekly as the data is variable, so I am trying to automate the work a bit.
My problem is, I want to copy an entire row of data if a specific cell contains a specific text.
I have been able to do so using this code:
Sub OK()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Status")
Set Target = ActiveWorkbook.Worksheets("OK")
j = 2
For Each c In Source.Range("F1:F300")
If c = "Yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
However, I want to use multiple conditions i.e. I only want the row to be copied if both column E and I contains "Yes".
My initial guess was this, but it doesnt seem right:
For Each c In Source.Range("F1:F300") AND Source.Range("I1:I300")
How can i add a condition to my code? I have tried using "and", but cant get it right it seems.
Thank you in advance.
You cannot add another Range in the way you have to a loop. Instead loop the one range as you originally put and as the additional range you want to check matches on a row by row basis but differs in terms of column use OFFSET to test the column I value in the same row. As below:
If c = "Yes" And c.Offset(0, 3) = "Yes"
So all together:
Sub OK()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Status")
Set Target = ActiveWorkbook.Worksheets("OK")
j = 2
For Each c In Source.Range("F1:F300")
If c = "Yes" And c.Offset(0, 3) = "Yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
The problem i run into is that sometimes entire headers and data values are missing in the dataset and therefore using the last row in the script the data is shifted up by one. For example, if i removed H11:H12 completely on sheet1 then the values for the H column associated with the data set in A11:K11 will actually be from the data set A13:K13 (or cell value H14).
The spaces shown in the second image would not be present if the respective header is not present.
Question: Given the following code; Do you think it is possible to match the data to headers and use the original offset row number alongside the column that it is matched to on sheet 2 and paste the values there? Instead the current code (and only method that worked was to find the last row).
Examples/Thoughts:
I'm thinking that the script will have to take a cell (such as D9 and recognizes it is a D and offsets to select D10 and matches that D9 record to sheet 2 column D and pastes the D10 data in D10 rather than D5.
second example, Script takes I17 and recognizes it matches I to sheet 2 column I and then offsets to select/copy and pastes the I19 data in I18 rather than I9.
Sub main()
Dim hedaerCell As Range
Dim labelsArray As Variant
With ThisWorkbook.Worksheets("Sheet2") '<--| reference "headers" worksheet
For Each hedaerCell In .Range("A1:K1") '<--| loop through all "headers"
labelsArray = GetValues(hedaerCell.Value) '<--| fill array with all labels found under current "header"
.Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).Value = Application.Transpose(labelsArray)
Next
End With
End Sub
Function GetValues(header As String) As Variant
Dim f As Range
Dim firstAddress As String
Dim iFound As Long
With ThisWorkbook.Worksheets("Sheet1").UsedRange '<--| reference "data" worksheet
ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
If Not f Is Nothing Then
firstAddress = f.Address
Do
iFound = iFound + 1
labelsArray(iFound) = f.Offset(1)
Set f = .FindNext(f)
Loop While f.Address <> firstAddress
End If
End With
GetValues = labelsArray
End Function
Addition:
Seems like there is an exception that prevents these cell values from being copied over, if i do it manually the below screenshot would be correct. Any tips to diagnose?
Very strange because the line with the red dot copies fine in both but those four lines seem to fail.
I'm leaving my previous answer up for posterity's sake, but now that you've clarified your question I have a better answer for you.
I'm going to assume the following: 1. every two rows is a pair of headers/data; 2. the sets of row pairs may be unequal in length because if a particular header is missing for a particular row pair, there is no blank because the headers/data are shifted left; 3. there will be no blanks in the header rows until the end of the row 4. there may be blanks in the data row 5. the output should be every header (even if it only appears in 1 row) and rows of the associated data, one per header/data pair in the original sheet.
For example:
A|B|C|D|F|G|H|I <--- some headers (missing E)
1|2|3|4|6|7|8|9 <--- data row 1
A|C|D|E|G|H|I <--- some headers (missing B and F)
1|3|4|5|7|8|9 <--- data row 2
is a valid input sheet and the resulting output sheet would be:
A|B|C|D|E|F|G|H|I <--- all headers
1|2|3|4| |6|7|8|9 <--- data row 1
1| |3|4|5| |7|8|9 <--- data row 2
Use a Scripting.Dictionary of Scripting.Dictionarys to keep track of the possibly different length row pairs of headers/data. The Scripting.Dictionary of headers allows you to add new headers as they appear. The nested Scripting.Dictionarys allow you to keep track of only those rows which have a value for a particular header, but also preserve the row number for later.
As noted in the comments, the code iterates through this structure to display ALL headers and the data associated with each row. "((inputRow - 1) / 2)" calculates the output row number. You'll notice I like to iterate for loops over the count and then use offsets for indexing. I find it easier to reason about my code this way, and I find operations are easier, but you could potentially change it if you want.
Public Sub CopyDataDynamically()
Dim inputSheet As Worksheet
Dim outputSheet As Worksheet
Dim headers As Scripting.Dictionary
Set headers = New Scripting.Dictionary
Dim header As String
Dim data As String
Dim inputRow As Long
Dim inputColumn As Long
Set inputSheet = Worksheets("Sheet1")
Set outputSheet = Worksheets("Sheet2")
inputRow = 1
While Not inputSheet.Cells(inputRow, 1) = ""
inputCol = 1
While Not inputSheet.Cells(inputRow, inputCol) = ""
header = inputSheet.Cells(inputRow, inputCol).Value
data = inputSheet.Cells(inputRow + 1, inputCol).Value
If Not headers.Exists(header) Then
headers.Add header, New Scripting.Dictionary
End If
headers(header).Add ((inputRow - 1) / 2) + 1, data
inputCol = inputCol + 1
Wend
inputRow = inputRow + 2
Wend
'Output the structure to the new sheet
For c = 0 To headers.Count - 1
outputSheet.Cells(1, c + 1).Value = headers.Keys(c)
For r = 0 To ((inputRow - 1) / 2) - 1
If headers(headers.Keys(c)).Exists(r + 1) Then
outputSheet.Cells(r + 2, c + 1).Value = headers(headers.Keys(c))(r + 1)
End If
Next
Next
End Sub
I suggest, rather than copying column by column, you instead copy row by row.
Public Sub CopyData()
Dim inputRow As Long
Dim outputRow As Long
Dim inputSheet As Worksheet
Dim outputSheet As Worksheet
Set inputSheet = Worksheets("Sheet1")
Set outputSheet = Worksheets("Sheet2")
'First, copy the headers
inputSheet.Rows(1).Copy outputSheet.Rows(1)
'Next, copy the first row of data
inputSheet.Rows(2).Copy outputSheet.Rows(2)
'Loop through the rest of the sheet, copying the data row for each additional header row
inputRow = 3
outputRow = 3
While inputSheet.Cells(inputRow, 1) <> ""
inputRow = inputRow + 1 'increment to the data row
inputSheet.Rows(inputRow).Copy outputSheet.Rows(outputRow)
inputRow = inputRow + 1 'increment to the next potential header row
outputRow = outputRow + 1 'increment to the next blank output row
Wend
End Sub
I want to merge cells in one row (belongs to Column B) with the count of already merged different cell(belongs to Column A) .How can i start coding ?
this is the screenshot that i want
Merging cells in a spreadsheet means taking two or more cells and
constructing a single cell out of them. When you merge two or more
adjacent horizontal or vertical cells, the cells become one larger
cell that is displayed across multiple columns or rows. When you
merge multiple cells, the contents of only one cell (the upper-left
cell for left-to-right languages, or the upper-right cell for
right-to-left languages) appear in the merged cell. The contents of
the other cells that you merge are deleted. For more details please
go through this MSDN article Merge and unmerge
cells
Simple VBA code for Merging Cell
Sub merg_exp_1()
ActiveSheet.Range("A1:C10").Merge
End Sub
Sample data before and after running the program is shown.
Now let us see, If we merge a row what happens. Sample code for this
exercise though general is being tested for one situation only and
it as follow :
Sub Merge_Rows()
Dim rng As Range
Dim rrow As Range
Dim rCL As Range
Dim out As String
Dim dlmt As String
dlmt = ","
Set rng = ActiveSheet.Range("A1:C5")
For Each rrow In rng.Rows
out = ""
For Each rCL In rrow.Cells
If rCL.Value <> "" Then
out = out & rCL.Value & dlmt
End If
Next rCL
Application.DisplayAlerts = False
rrow.Merge
Application.DisplayAlerts = True
If Len(rrow.Cells(1).Value) > 0 Then
rrow.Cells(1).Value = Left(out, Len(out) - 1)
End If
Next rrow
End Sub
Sample data before and after running the program is shown. You can see this won't meet your objective.
Next we can try merging by column approach. Here also we are trying
for one column i.e. Column B to see the effect. Sample code as
follows.
Sub Merge_col_exp()
Dim cnum As Integer
Dim rng As Range
Dim str As String
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
cnum = Cells(i, 1).MergeArea.Count
Set rng = Range(Cells(i, 2), Cells(i - cnum + 1, 2)) ' only to demonstrate working in 2nd column
For Each cl In rng
If Not IsEmpty(cl) Then str = str + "," + cl
Next
If str <> "" Then str = Right(str, Len(str) - 1)
Application.DisplayAlerts = False
rng.Merge
rng = str
Application.DisplayAlerts = True
str = ""
i = i - cnum + 1
Next i
End Sub
Sample data before and after running the program is shown. You can see this is closer to your requirement. You can extend functionality of this program by finding Last Column in the Actively used range. Extend program functionality to cover upto last column.
I am looping through a range in Excel VBA. I have an IF-Then that checks to see if the a cell contains a number. I then want the address of the cell that contains the number. The problem is my code returns the first cell with a number over and over.
For Each Row in Room.Rows
If IsNumber(Row.Cells(,1)) then
x = (Row.cells(,1))
End If
Next Row
For Each Row in Room.Rows
If WorksheetFunction.IsNumber(range("A" & Row.row)) then
x = range("A" & Row.row).address
// do stuff with x
End If
Next Row
1) don't use variable names that will confuse people (row)
2) in the for each loop example, you don't need to add the .rows ,
considering your named variable 'row' is a row type.
3) Declare all your variables
4) i changed the code with an other approach :
Dim R as Long
Dim Rg as Range
Dim x as String
For R=1 to Room.rows.count
set Rg= Room.cells(r,1)
If IsNumeric(Rg) then
x = Rg.address
// do stuff with x
End If
Next R
set rg= nothing
I have a spreadsheet with a column of data day of the week and using a macro to execute a VBA. Column A is the day of the week and Column B is the name of the object. When I run the macro, it runs a For loop through a Named List and will populate the items in a calendar on another sheet. The macro works fine as long as I have the Named List in a fixed length (ie $L2:$A14) so if I add new data, I would need to fix the Named List.
Sub UpdateCalendar()
i = 2
Dim strRngName As String
lngLast = Sheets("Servers").Range("B" & Rows.Count).End(xlUp).Row
For Each c In Application.Range("ScheduledDates")
strRngName = c.Text
strUser = c.Offset(0, -1).Value
User = c.Offset(0, -10).Value
If (i > 45) Then
<code stuff>
i = i + 1
Next
End Sub
I tried switching line 5 to something like this:
For Each c In Sheets("Servers").Range("L" & Rows.Count).End(x1Up).Row
but it doesn't like that (I'm guessing it doesn't see it as a full array?). The problem with the way this executes is if the "ScheduledDates" field is blank, it will throw an error and stop the script, thus I'm using a fixed length in my Named List. Not sure if there's any way around this.
First, dim c as range, then update your code to:
For Each c In Sheets("Servers").Range("L2:L" & Sheets("Servers").cells(Rows.Count,"L").End(xlUp).Row).cells
or
dim c as range, lLastRow as long
lLastRow=Sheets("Servers").cells(Rows.Count,"L").End(xlUp).Row
For Each c In Sheets("Servers").Range("L2:L" & lLastRow).cells
You can also update the definition of your named range so it becomes a dynamic named range, either using an =offset( / counta structure, of by referencing a listObject
Assuming that column B always has an entry, I prefer this approach:
Sub UpdateCalendar()
Dim rng as Range
Dim strRngName As String
Set rng as Sheets("Servers").Range("B2")
While rng <> ""
strRngName = rng.Text
strUser = rng.Offset(0, -1).Value
'!!!Below line will cause an error in your code as B2 offset by -10 would be B-8!!!
User = rng.Offset(0, -10).Value
If (rng.Row > 45) Then
'<code stuff>
Set rng = rng.Offset(1)
Wend
End Sub
You can use your original code by making the named range dynamic.
For Example, entering the below formula in the 'Refers To' field of the named range selects a range from A2:C where is the row number of the last filled row.
=OFFSET(Sheet1!$A$1,1,0,COUNTA(Sheet1!$A:$A)-1,3)
(assuming data extends from col A to col C with headers in row1)