Concatenate Cell Values Dynamically And Copy Result to Another Worksheet - vba

I have a worksheet ("Data") with x-columns and y-rows. I want to concatenate the values of a row and the concatenated result should be copied to a second worksheet ("Insert") in the first column of the same row.
I tried this VBA and get an error message
Sub InsertStatementRow()
Dim x As String, rng As Range, rng1 As Range, cel As Range
Dim ColMax As Integer
Dim i As Long
Sheets("Data").Select
Range("A1").Select
ColMax = Cells(1, Columns.Count).End(xlToLeft).Column
With Worksheets("Data")
i = 1
Set rng = Range(Cells(i, 1), Cells(i, ColMax))
End With
For Each cel In rng
x = x & cel.Value
Next
Range(Sheets("Insert").Cells(i, 1)).Value = x
End Sub
Please show me what I am doing wrong by correcting my code. Thanks!


Use some "." :
Set rng = Range(.Cells(i, 1), .Cells(i, ColMax))

Related

Selecting a range from a specific cell and then special paste that range using VBA

i have an excel file in which i have data month wise, so i want to select Column F, G and H from the active cell till the last data of that column and then special paste it.
I am using this Code for selecting that range but not able to do that. it is selecting the data from the F1.
Sub selecting_range()
Dim rng As Range
Dim LastRow As Long
currentcell = ActiveCell
LastRow = Cells(Rows.Count, "F" & currentcell).End(xlUp).Row
Set rng = Range("F1:H" & LastRow)
rng.Select
End Sub

Considering the fact that the "F" and "H" are hardcoded, then you can build up something like this:
Sub SelectingRange()
Dim rng As Range
Dim lastRow As Long
lastRow = Cells(Rows.Count, "F").End(xlUp).Row
Set rng = Range(Cells(ActiveCell.Row, "F"), Cells(lastRow, "H"))
rng.Select
End Sub
Or you can write it in 1-line, just to confuse someone:
Sub SelectingRange()
Range(Cells(ActiveCell.Row, "F"), Cells(Cells(Rows.Count, "F").End(xlUp).Row, "H")).Select
End Sub

Filldown makes my formula disappear Excel VBA

Looking to fill a variable range here. I can fill my formula to the right but when I want to fil it down, the formula disappears. I have also attached a picture and Column A starts with "Fund Name". Hope somebody can help me here thank you!! The link to the table is here. 1: https://i.stack.imgur.com/y1ZVH.png
Sub Six_Continue()
Dim Lastrow As Long
Dim lrow As Range
Dim Lastcol As Long
Dim lcol As Range
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set lrow = Range("C5:C" & Lastrow)
Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Set lcol = Range("C3", Cells(3, Lastcol))
Range("C5").FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
Range("C5", lcol.Offset(2)).FillRight
Range("C5", lcol.Offset(2)).FillDown
End Sub

The code below worked for me (with a much simplified array formula).
Sub Six_Continue()
' 25 Jan 2018
Dim Rng As Range
Dim LastRow As Long
Dim LastClm As Long
With ActiveSheet ' better specify by name
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
Cells(5, 3).FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
' .Cells(5, 3).FormulaArray = "= $a1 * $k1:$k5 * C$1"
Set Rng = Range(.Cells(5, 3), .Cells(5, LastClm))
Rng.FillRight
Set Rng = Range(.Cells(5, 3), .Cells(LastRow, LastClm))
Rng.FillDown
End With
End Sub

Making "Countif" worksheet function variable

I have a code that counts the cell in a range if there's a number. The total number of cell counted will then be shown in row 3. My issue now is that the formula is not variable and I have no idea how to make it too.
If I enter this code, row 3 reports all the same result (which is from the first column of data). Hoping somebody can help me here!!
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long
With ActiveSheet
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = Range(.Cells(3, 3), .Cells(3, LastClm))
Rng.Value = Application.WorksheetFunction.CountIf(Range("C5", "C" & Cells(Rows.Count, 5).End(xlUp).Row), "<>?")
End With
End Sub

Your CountIf will count cells even if they don't contain a number. Using Count ensures that only cells containing numbers are taken into account.
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long
Dim myClm As Long
With ActiveSheet
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
For myClm = 1 To LastClm
Set Rng = .Cells(3, myClm)
Rng.Value = Application.WorksheetFunction.Count(Range(.Cells(5, myClm), .Cells(.Cells(Rows.Count, myClm).End(xlUp).Row, myClm)))
Next myClm
End With
End Sub

Try this modified version:
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long, i As Long
LastClm = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LastClm
Cells(3, i).Value = Application.WorksheetFunction.CountIf(Range(Cells(1, i), Cells(2, i)), "<>?")
Next
End Sub

VBA find a range of same values in a column and calculate average

I want to find a range of same values in column A , and then calculate it average , can anyone help me ? below the code :
https://i.stack.imgur.com/bU1hW.png
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
Columns("A:A").Select
Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
'do it another thing
End If
End Sub
Thanks !

Solution 1
Try this
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
See image for reference.
Solution 2
Another easier approach will be to use formula. Enter the following formula in Cell E2
=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)
Drag/Copy down as required. Change range as per your data.
For details on AVERAGEIF see this.
EDIT : 1
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Dim dict As Object, c As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
c = aRng
For i = 1 To UBound(c, 1)
dict(c(i, 1)) = 1
Next i
.Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys) 'display uniques from column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
EDIT : 2 To get Min, instead of
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
use
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value

Use WorksheetFunction.AverageIf function, see code below :
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:A" & LastRow)
' average of values in column B of all cells in column A = 1
Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))
' average of values in column B of all cells in column A = 2
Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With
End Sub

This is using a variant array method. Try this.
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim vDB, vR(), rngDB, vResult()
Dim r As Integer, n As Long, j As Long, i As Integer
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
rngDB = .Range("a1", "b" & LastRow)
vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vResult(1 To r)
For i = 1 To r
n = 0
For j = 1 To LastRow
If vDB(i, 1) = rngDB(j, 1) Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = rngDB(j, 2)
End If
Next j
vResult(i) = WorksheetFunction.Average(vR)
Next i
.Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
End With
End Sub

To use the .Find Function
Find the values in column A excluding duplicates
Use the unique values on the Find Function
When the value is found, sum the value in column B and on a counter
Divide the sum value by the counter to obtain the average value
Dim ws As Worksheet
Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
Set ws = ThisWorkbook.Sheets(1)
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
For i = 2 To lastrow
Set c = ws.Cells(i, 1)
Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
x = Application.WorksheetFunction.CountIf(rngloop, c)
If x = 1 Then
'Debug.Print c 'Values in column A without duplicates
'Work with the values found
With rng
Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
If Not cellFound Is Nothing Then
FirstAddress = cellFound.Address
Do
SumValues = ws.Cells(cellFound.Row, 2) + SumValues
k = k + 1
Set cellFound = .FindNext(cellFound)
Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
AverageValues = SumValues / k
Debug.Print "Value: " & c & " Average: " & AverageValues
End If
End With
End If
k = 0
SumValues = 0
Next i
Note that the use of .Find is slower than CreateObject("Scripting.Dictionary"), so for large Spreadsheets the code of #Mrig is optimized

Please try this code:
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
'if found more than one value
'do it another thing
sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
Else
'do it another thing
End If
Next i
End Sub
Hope this help.

VBA Copy Formula to Last Row Then Next Column

I'm working with the code below, and where I'm having a hard time getting this around is the piece in brackets [CURRENT COLUMN]
I can't quite seem to get it to use the currently used column to paste the formula down.
The goal is to go from columns K to END then if there is a formula in row 2 of that column, copy that formula down and proceed to the next column.
Option Explicit
Sub recalcdash()
Dim oWkbk As Workbook
Dim oWkst As Worksheet
Dim oRng As Range
Dim LastCol As Long
Dim LastRow As Long
Dim StartCol As Integer
Dim StartRow As Long
StartCol = 11
Set oWkst = ActiveSheet
LastRow = oWkst.Range("A" & oWkst.Rows.Count).End(xlUp).Row
LastCol = oWkst.Cells(2, oWkst.Columns.Count).End(xlToLeft).Column
For Each oRng In Range(Cells(2, 11), Cells(2, LastCol))
If oRng.HasFormula Then
oRng.Copy
Range(Cells(2, StartCol), Cells(LastRow, [CURRENT COLUMN])).PasteSpecial (xlPasteFormulas)
End If
Next oRng
End Sub

Try to modify
Range(Cells(2, StartCol), Cells(LastRow, [CURRENT COLUMN])).PasteSpecial (xlPasteFormulas
to
Range(Cells(2, oRng.Column), Cells(LastRow, oRng.Column)).PasteSpecial (xlPasteFormulas)