I am trying to fill out a table by summing the first "x" number of values then the next "x" number of values.
Essentially this:
=SUM(Ax:Ay) where x and y are the row numbers
Sheets(1).Range("B"+i).Formula = "=SUM(A" & x & ":A" & y & ")"
Here is what my actual code looks like:
Private Sub ScrollBar1_Change()
Application.ScreenUpdating = False
Dim slider_val As Long
Dim output_tbl As ListObject
Dim data_tbl As ListObject
Dim i As Long
Dim j As Long
Dim start As Long
Dim finish As Long
Set data_tbl = Sheets("Data").ListObjects("DataTable")
Set output_tbl = Sheets("Slider").ListObjects("OutputTable")
slider_val = Sheets("Slider").Range("A5").Value
start = 2
For i = 1 To 12
finish = start + slider_val
Sheets("Slider").Range("B" & j).Formula = "=SUM(Data!K" & start & ":K" & finish & ")"
j = j + 1
start = finish + 1
Next i
Application.ScreenUpdating = True
End Sub
I get the error "Application-defined or object-defined error" when I try to run this code.
Thank you all for your help, the problem was that I had not defined "j" yet.
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
I have been trying to Concatenate two Columns directly from the Table1. But i really do not know how. I have tried and make below code.
But I have been creating first 2 helping Column in in "DI" and "DJ" to make this thing work.
I do not want to use these two helping columns directly wants the concatenate result in "DK2"
All help will be appreciaed.
Dim O As String
Dim P As String
O = "Milestone"
P = "Task"
Sheet1.Range("Table1[" & O & "]").Copy
Sheet2.Range("DI2").PasteSpecial xlPasteValues
Sheet1.Range("Table1[" & P & "]").Copy
Sheet2.Range("DJ2").PasteSpecial xlPasteValues
For i = 2 To Cells(Rows.Count, "DH").End(xlUp).Row
Sheet2.Cells(i, "DK").Value = Sheet2.Cells(i, "DI").Value & "" & Sheet2.Cells(i, "DJ").Value
Next i
Here is the example Picture
Try this.
Range("DK2").Resize(Sheet2.ListObjects("Table1").ListRows.Count) = Application.Evaluate("Table1[Milestone]&Table1[Task]")
EDIT: I've seen #norie's answer and it is simpler and more efficient than mine. I'll keep my answer here for anyone who is curious, but I recommend using his solution.
The trick is to use =INDEX(YOUR_TABLE[YOUR_COLUMN]], YOUR_ROW_STARTING_FROM_1) in order to obtain the cell contents that you needed.
Here you are your code edited:
Original
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
Optimized
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using only Formulas (this performs better that the others)
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using Formulas and then converting back to values
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
' Convert from formulas to values
Range("DK:DK").Copy
Range("DK:DK").PasteSpecial xlPasteValues
This can be done directly in the worksheet by using the Index function
Reference first cell in the table: =INDEX(Table1,1,1)
Concatenate cell 1 and 2 values: =INDEX(Table1,1,1)&INDEX(Table1,1,2)
It gets slightly more complicated if you want to be able to copy formulae across or down as you need to reference the current cell location
Reference first cell in the table using offsets: =INDEX(Table1,ROW()-X,COLUMN()-Y) where X, Y (minus data location offsets) are the numerical row/column of the cell where you have placed the formula.
i.e. if placing the formula in E2 to reference Table1 cell(1,1) => =INDEX(Table1,ROW()-1,COLUMN()-4)
where Column E=> Offset 4, Row 2 => Offset 1
or: =INDEX(Table1,ROW()-ROW($E$2)+1,COLUMN()-COLUMN($E$2)+1)
You can now autofill the formula down or across
Concatenate List Columns
With your amount of data both solutions may seem equally efficient. I've tested it with a million rows of random numbers from 1 to 1000, and the first solution took about 3.5 seconds, while the second took about 5.5 seconds on my machine. The first solution is just a more elaborate version of norie's answer.
In this solution, you can add more columns (headers) and use a delimiter. While adding more columns the difference in the efficiencies will become more apparent, while when adding more characters to the delimiter, the efficiencies will decrease seemingly equally.
The Code
Option Explicit
Sub concatListColumnsEvaluate()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Determine table rows count.
Dim rCount As Long: rCount = Sheet1.ListObjects(TableName).ListRows.Count
' Create Evaluate Expression String.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim evString As String
Dim t As Long
If Len(Delimiter) = 0 Then
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&"
Next t
evString = Left(evString, Len(evString) - 1)
Else
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&""" _
& Delimiter & """&"
Next t
evString = Left(evString, Len(evString) - Len(Delimiter) - 4)
End If
' Write values to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Application.Evaluate(evString)
Debug.Print Timer - dTime
End Sub
Sub concatListColumnsArrays()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Write values from list columns to arrays of Data Array.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim Data As Variant: ReDim Data(0 To tUpper)
Dim t As Long
For t = 0 To tUpper
' Either...
Data(t) = Sheet1.Range(TableName & "[" & Headers(t) & "]").Value
' ... or:
'Data(t) = Sheet1.ListObjects(TableName) _
.ListColumns(Headers(t)).DataBodyRange.Value
Next t
' Concatenate values of arrays of Data Array in Result Array.
Dim rCount As Long: rCount = UBound(Data(0), 1)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long
If Len(Delimiter) = 0 Then
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1)
Next t
Next r
Else
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1) & Delimiter
Next t
Result(r, 1) = Left(Result(r, 1), Len(Result(r, 1)) _
- Len(Delimiter))
Next r
End If
' Write values from Result Array to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Result
Debug.Print Timer - dTime
End Sub
I am trying to identify a specific range in column-A and concatenate two cells within the specific range and delete the empty cell. I have been successful in putting a code together and it does the job very well. But, I don't know how to loop it to identify next range. Any help would be appreciated.
As per below image and code, First, I am finding and selecting a range between two (MCS) in column-A with a condition that, if the rows are more than 8 between two MCS. Then I am concatenating first 2 cells immediately after MCS and delete the empty row.
The below code works well for first range but I am unable to loop to identify next range from row 22 to 32 and perform concatenations.
I dont know how to loop in column-A and select ranges and concatenate. Any help would be much appreciated. Thanks
Sub MergeStem()
Dim findMCS1 As Long
Dim findMCS2 As Long
Dim myCount As Integer
Dim myStems As Long
Dim mySelect As Range
Dim c As Range
findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row
myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
Range("B1").Value = myCount
MsgBox "Number of rows =" & myCount
Set mySelect = Selection
If myCount > 8 Then
myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select
Set mySelect = Selection
For Each c In mySelect.Cells
If firstcell = "" Then firstcell = c.Address(bRow, bCol)
sArgs = sArgs + c.Text + " "
c.Value = ""
Next
Range(firstcell).Value = sArgs
End If
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Can you try this? Ordinarily, Find would be the way to go but because you are deleting rows it's hard to keep track of which cells you've found.
Sub x()
Dim r As Long, n1 As Long, n2 As Long
With Range("A1", Range("A" & Rows.Count).End(xlUp))
For r = .Count To 1 Step -1
If .Cells(r).Value = "MCS" Then
If n1 = 0 Then
n1 = .Cells(r).Row
Else
n2 = .Cells(r).Row
End If
If n1 > 0 And n2 > 0 Then
If n1 - n2 > 9 Then
.Cells(r + 1).Value = .Cells(r + 1).Value & .Cells(r + 2).Value
'.Cells(r + 2).EntireRow.Delete
'Call procedure to delete row
End If
n1 = n2
n2 = 0
End If
End If
Next r
End With
End Sub
I am trying to identify a specific range in column-A and concatenate two cells within the specific range and delete the empty cell. I have been successful in putting a code together and it does the job very well. But, I don't know how to loop it to identify next range. Any help would be appreciated.
As per below image and code, First, I am finding and selecting a range between two (MCS) in column-A with a condition that, if the rows are more than 8 between two MCS. Then I am concatenating first 2 cells immediately after MCS and delete the empty row.
The below code works well for first range but I am unable to loop to identify next range from row 22 to 32 and perform concatenations. I want to loop in column-A as there will be more MCS.
Sub MergeStem()
Dim findMCS1 As Long
Dim findMCS2 As Long
Dim myCount As Integer
Dim myStems As Long
Dim mySelect As Range
Dim c As Range
findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row
myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
Range("B1").Value = myCount
MsgBox "Number of rows =" & myCount
Set mySelect = Selection
If myCount > 8 Then
myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select
Set mySelect = Selection
For Each c In mySelect.Cells
If firstcell = "" Then firstcell = c.Address(bRow, bCol)
sArgs = sArgs + c.Text + " "
c.Value = ""
Next
Range(firstcell).Value = sArgs
End If
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You could try:
Option Explicit
Sub test()
Dim i As Long, Lastrow As Long, Startpoint As Long, Endpoint As Long, Diff As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Startpoint = 0
Endpoint = 0
For i = Lastrow To 2 Step -1
str = .Range("A" & i).Value
If str = "MCS" And Startpoint = 0 Then
Startpoint = i
ElseIf str = "MCS" And Startpoint <> 0 Then
Endpoint = i
End If
If Startpoint > 0 And Endpoint > 0 Then
Diff = Startpoint - Endpoint
If Diff > 8 Then
.Range("A" & Endpoint + 1).Value = .Range("A" & Endpoint + 1).Value & " " & .Range("A" & Endpoint + 2).Value
.Rows(Endpoint + 2).EntireRow.Delete
Startpoint = 0
Endpoint = 0
End If
End If
Next i
End With
End Sub
I'm building an master excel file that is designed to gather data from lots of other excel files that are stored in the business Dropbox files and place them in the 2nd sheet of the master file. I built a original version on my local computer and that worked perfectly (the path3 variable) but once I tried to convert it based on a changing file path (because each user will have a different path from their PC) I am getting the run time error. The formula defined by path2 is what I have been trying to use but even though the variable seems to be holding the right value (I tested it by having it write out the values) it doesn't seem to be able to move the data, throwing the above error and highlighting the "rngdest.Formula = Chr(61) & path2" line. I really don't have any idea what is causing this and I have spent several days trying different approaches but to no avail so any ideas, solutions or links to already solved (I have spent a long time searching but haven't found anything) would be very much appreciated.
I've included the whole of the code for completeness, I think I've removed most of the redundant code that I left in but there may be some still left. If you need any clarifications on the code please let me know. Thanks for any potential help
Private Sub CommandButton2_Click()
Dim counter As Integer
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim a As Integer
Dim z As Integer
Dim y As Integer
Dim p As Integer
Dim Names() As String
Dim Fix1() As String
Dim path3 As String
Dim path2 As String
Dim SheetName As String
Dim c As Range
Dim found As Range
Dim BookName As String
Dim var1 As String
Dim rngdest As Range
Dim rngsource As Range
Dim cell As String
Dim adjust As Integer
Dim adjust2 As Integer
Dim rngname As Range
Dim colNo As Integer
Dim fin As String
Dim fin2 As String
Dim fin3 As String
Dim comp As String
Dim teststring As String
Dim currentWb2 As Workbook
Set currentWb2 = ThisWorkbook
MsgBox "Excel will now update the sheet, please be patient as this can take a few minutes. You will be notified once it is complete"
ReDim Fix1(1 To 4)
Fix1(1) = "A-F"
Fix1(2) = "G-L"
Fix1(3) = "M-R"
Fix1(4) = "S-Z"
counter = 0
With ActiveSheet
i = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
ReDim Names(1 To i, 1 To 4)
With ActiveSheet
For k = 1 To 4
For a = 2 To i
Names(a, k) = Cells(a, k).Value
Next a
Next k
End With
SheetName = "Analysis"
BookName = "Outcomes Final.xlsm"
For p = 1 To 4
fin2 = Split(Cells(, p).Address, "$")(1)
With ActiveSheet
l = .Cells(.Rows.Count, fin2).End(xlUp).Row
End With
For z = 1 To l
counter = counter + 1
fin = Split(Cells(, counter).Address, "$")(1)
currentWb2.Sheets("Sheet2").Range("" & fin & "1") = Names(z, p)
For y = 1 To 34
adjust = y + 1
cell = "$B$" & y & ""
If z = 1 Then
Else
teststring = GetPath()
teststring = teststring & "\Clients\"
path3 = "'C:\Users\Lewis\Documents\Outcomes\Floating Support\Clients\" & Fix1(p) & "\" & Names(z, p) & "\[Outcomes Final.xlsm]Analysis'!" & cell & ""
path2 = teststring & Fix1(p) & "\" & Names(z, p) & "\Outcomes\[Outcomes Final.xlsm]Analysis'!" & cell & ""
End If
Set rngdest = currentWb2.Sheets("Sheet2").Range("" & fin & "" & adjust & "")
Set rngsource = Range("B" & y & "")
rngdest.Formula = Chr(61) & path2
Next y
Next z
Next p
currentWb2.Sheets("Sheet2").Columns(1).EntireColumn.Delete
currentWb2.Sheets("Sheet1").Range("A1:D35").Interior.ColorIndex = 0
For j = 1 To counter
fin3 = Split(Cells(, j).Address, "$")(1)
If currentWb2.Sheets("Sheet2").Range("" & fin3 & "35") = "1" Then
With currentWb2.Sheets("Sheet1").Range("A1:D35")
comp = currentWb2.Sheets("Sheet2").Range("" & fin3 & "1")
Set c = .Find(comp, LookIn:=xlValues)
If Not c Is Nothing Then
c.Interior.ColorIndex = 3
End If
End With
End If
Next j
MsgBox "The update is now complete, please click on sheet 2 to view the data. All clients in red have not been properly completed"
End Sub