I wanna ask related to excel vba.
I'm trying to consolidate data from worksheet, containing data like screenshot(1).
What i'm want to do is to consolidate data with unique row is in row H (CTP.GRP) and sum column M(Nominal) populate to another sheet in column utlization & column P(Mtm in IDR) Popullate data to another sheet column market value
My code only sum one column, anyone can help with code how to sum two column?
Sub ins_data()
Dim x As Variant
Dim y As Variant
Dim countDict As Variant
Dim a As Long
Set countDict = CreateObject("Scripting.Dictionary")
x = Sheets("Data").Range("A2").CurrentRegion
ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
For a = 2 To UBound(x, 1)
cat1 = x(a, 8)
val1 = x(a, 16)
If countDict.exists(cat1) Then
countDict(cat1) = countDict(cat1) + val1
Else
countDict(cat1) = val1
End If
Next a
i = 1
For Each d In countDict
y(i, 2) = d
y(i, 8) = countDict(d)
i = i + 1
Next d
ThisWorkbook.Sheets("X").Range("B5").Resize(UBound(y), UBound(y, 2)).Value = y
Expected result:
Edited after OP’s further clarification
you could use this code:
Option Explicit
Sub ins_data()
Dim countDict As Object, countDict2 As Object
Set countDict = CreateObject("Scripting.Dictionary")
Set countDict2 = CreateObject("Scripting.Dictionary")
Dim x() As Variant
x = Sheets("Data").Range("A2").CurrentRegion.Value2
Dim a As Long
For a = 2 To UBound(x, 1)
countDict(x(a, 8)) = countDict(x(a, 8)) + x(a, 13)
countDict2(x(a, 8)) = countDict(x(a, 8)) + x(a, 16)
Next
With ThisWorkbook.Sheets("X").Range("B5").Resize(countDict.Count) ‘ change “B5” to the actual worksheet “X” cell you want to start writing Sheets("Data")) column H unique values from
.Value = Application.Transpose(countDict.Keys)
.Offset(, 6).Value = Application.Transpose(countDict.Items) ‘ change “6” to your actual column offset from Sheets("X") referenced column (currently, “B”) you want to start writing Sheets("Data")) column M consolidated sum from
.Offset(, 7).Value = Application.Transpose(countDict2.Items) ‘ change “7” to your actual column offset from Sheets("X") referenced column (currently, “B”) you want to start writing Sheets("Data")) column P consolidated sum from
End With
End Sub
Related
I need additional info in sheet2, but I cant figure out how to add this.
I have in sheet1 a lot of data, but everything is divided into 3 sections
Section 1 of sheet1 is in columns A,B,C,D and contains -date,time,name,last
Section 2 of sheet1 is numeric data and its range is columns E to JX
Section 3 of sheet1 is in range JY:MV and it contains results(from section2)
Code that I have goes through section 3 and if value is <1 it copies that value into sheet 2 in column F, and it copies from that row section 1
Example:
If value 0.5 is found in sheet1 K32, sheet 2 looks like :
A B C D F
date time name last 0.5
Tasks that I need help
1)Is it possible to see in sheet2 in column E a sheet1 column name from where is value found?
2) Since every value in section 3 is result from 2 values from section2, can both of these values also be copies to sheet 2?
For Example
In sheet1, K50 is 0.2 and that result is from AA50(2.2) and AC50(2.0),formula used is (AA-AC)
Is it possible to copy 2.2 and 2.0 in sheet 2 also based on formula cell reference?
Summary:
Final sheet2 should look like this:
A B C D E F G H
date, time, name, last, Column name where value is found, value, data1, data2
So I need help do add columns E,G and H
Sub moveData()
Dim rng As Range
Dim iniCol As Range
Dim i
Dim v
Dim x
Dim myIndex
Dim cellVal
Dim totalCols
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim ABC() 'var to store data from Cols A,B,C in Sheet1
Dim JYJZKA As Range 'var to store data from Cols K,L,M in Sheet1
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
Set rng = Range("JY1:KB400")
Set iniCol = Range("JY1:JY400")
totalCols = rng.Columns.Count 'Count the total of columns in the selectec range
myIndex = 0 'ini the index for rows in sheet2
For Each i In iniCol
x = -1
ABC = Range(Cells(i.Row, 1), Cells(i.Row, 4))
Set JYJZKA = Range(Cells(i.Row, 285), Cells(i.Row, 351))
'Copy range from A to C
sht2.Activate
myIndex = Application.WorksheetFunction.CountA(Columns(1)) + 1
For Each v In JYJZKA
If v.Value < 1 Then
x = x + 1
Range(Cells(myIndex + x, 6), Cells(myIndex + x, 6)).Value = v.Value
Range(Cells(myIndex + x, 1), Cells(myIndex + x, 4)).Value = ABC
End If
Next v
'Paste range equal to copy range.
'Application.CutCopyMode = False
sht1.Activate
Next i
End Sub
See if this can get your started.
I've loaded the large block of data into a variant array. This greatly speeds up the looping through individual cell comparisons.
Sub section_3_to_Sheet2()
Dim r As Long, c As Long, vVALs As Variant, vTMP As Variant
With Worksheets("Sheet1")
With .Range(.Cells(2, 1), .Cells(Rows.Count, "MV").End(xlUp))
vVALs = .Value2
End With
End With
With Worksheets("Sheet2")
For r = LBound(vVALs, 1) To UBound(vVALs, 1)
For c = 285 To UBound(vVALs, 2)
If vVALs(r, c) < 1 Then
vTMP = Array(vVALs(r, 1), vVALs(r, 2), vVALs(r, 3), vVALs(r, 4), _
"=ADDRESS(" & r + 1 & ", " & c & ", 4, 1, """ & .Name & """)", _
vVALs(r, c), vVALs(r, c - 280))
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 7) = vTMP
End If
Next c
Next r
End With
End Sub
Typically, blocks of data like this have column header labels so I started you off in row 2, not row1 as your sample data might indicate.
The location of the original data is supplied with an ADDRESS function.
Since E:JX is not the same number of columns as JY:MV, I was a little confused on what value to return as the second (e.g. data2) value. I opted for a simple offset.
I want to copy a range of cells to another worksheet based on the criterion given in column N. So for each row it has to check whether or not it meets criterion in column N. If the value in Column N = 1, it should copy from that row Range(Cells(j, 1), Cells(j, 8)) to another worksheet starting at row 10. If the value in Column N = 0 it skips that row and checks the next one. So it doesn't copy that row.
Maybe my wrong code can explain it better than me:
Sub TCoutput()
Dim i As New Worksheet
Dim e As New Worksheet
Set i = ActiveWorkbook.Worksheet.Item(3)
Set e = ActiveWorkbook.Worksheets.Item(4)
Dim d
Dim j
d = 10
j = 3
Do Until IsEmpty(i.Range("N" & j))
If i.Range("N" & j) = "1" Then
d = d + 1
e.Range(Cells(d, 1), Cells(d, 8)) = i.Range(Cells(j, 1), Cells(j,8))
End If
j = j + 1
Loop
End Sub
When using multiple spreadsheets, you need to be careful and make sure all .Range and .Cells references include the worksheet you want to. First things first, replace your If statement with this one:
If i.Range("N" & j) = "1" Then
e.Range(e.Cells(d, 1), e.Cells(d, 8)) = i.Range(i.Cells(j, 1), i.Cells(j,8))
End If
Or, you can use With (which I personally prefer):
With i
If .Range("N" & j) = "1" Then
e.Range(e.Cells(d,1),e.Cells(d,8)) = .Range(.Cells(j,1),.Cells(j,8))
End If
End with
Without the explicit reference to a worksheet, the Cells() and Range() will defer to whichever one is the ActiveSheet.
try this. Ive add .value and d =d + 1
Sub TCoutput()
Dim i As New Worksheet
Dim e As New Worksheet
Set i = ActiveWorkbook.Worksheets.Item(1)
Set e = ActiveWorkbook.Worksheets.Item(2)
Dim d
Dim j
d = 10
j = 3
Do Until IsEmpty(i.Range("N" & j))
If i.Range("N" & j) = "1" Then
e.Range(e.Cells(d, 1), e.Cells(d, 8)).Value = i.Range(i.Cells(j, 1), i.Cells(j, 8)).Value
d = d + 1
End If
j = j + 1
Loop
End Sub
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2). I'd like to set this up such that the program loops through every row in the column (A2:A400), and clears the corresponding values.
I tried using the following code, which I modified from another post:
Sub clear_cell()
Dim v
v = Excel.ThisWorkbook.Sheets("TOP LINE").Range("B2").Value
Dim Arr() As Variant
Arr = Sheet1.Range("C2:DGJ2")
Dim r, c As Long
For r = 1 To UBound(Arr, 1)
For c = 1 To UBound(Arr, 2)
If Arr(r, c) > v Then
Arr(r, c) = ""
End If
Next c
Next r
Sheet1.Range("C2:DGJ2") = Arr
End Sub
I modified it to fit my needs, but it only works for the first row. I need some help getting it to loop through every row in the first column.
Thank you for the help.
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2).
From the above statement, I am assuming that all ranges are in the same sheet. Your code works for me if I make a few changes. See this
Sub clear_cell()
Dim i As Long, j As Long
Dim Arr
'~~> Set Range here
Arr = Sheet1.Range("A2:DGJ400").Value
For i = 1 To UBound(Arr, 1)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) > Arr(i, 1) Then
Arr(i, j) = ""
End If
Next j
Next i
'~~> Write back to the sheet
Sheet1.Range("A2:DGJ400") = Arr
End Sub
give this a try:
Sub clear_cell()
x = 2
Do While x <= 400
Y = Range(Cells(x, 2), Cells(x, 2)).Value
If Y < 100 Then Range(Cells(x, 2), Cells(x, 2)).FormulaR1C1 = ""
x = x + 1
Loop
End Sub
The 2 is the column range, in this case B. Good Luck.
I'm trying to figure out a way to combine rows based on values in two specific columns in vba excel.
For Example:
Let's say I have the following sheet:
Column A Column J Column Z
1 A ?
1 A !
2 B ?
2 B !
And I need to convert it to this:
Column A Column J Column Z
1 A ?, !
2 B ?, !
Here's another method using User Defined Types and collections to iterate through the list and develop the combined results. For large sets of data, it should be considerably faster than reading through each cell on the worksheet.
I assume that you are grouping on Col J, and that Column A data does not need to be concatenated in the cell. If it does, the modifications to the routine would be trivial.
First, Insert a Class Module, rename it CombData and insert the following code into that module:
Option Explicit
Private pColA As String
Private pColJ As String
Private pColZConcat As String
Public Property Get ColA() As String
ColA = pColA
End Property
Public Property Let ColA(Value As String)
pColA = Value
End Property
Public Property Get ColJ() As String
ColJ = pColJ
End Property
Public Property Let ColJ(Value As String)
pColJ = Value
End Property
Public Property Get ColZConcat() As String
ColZConcat = pColZConcat
End Property
Public Property Let ColZConcat(Value As String)
pColZConcat = Value
End Property
Then Insert a Regular Module and insert the Code Below:
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1").Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
EDIT: Note that the source data is read into the Variant array V. If you examine V in the Watch Window, you will see that the first dimension represents the rows; and the second dimension the columns. So if you wanted, for example, to perform the same procedure on a different set of columns, you would merely change the references to the second dimension under the line that reads Set cCombData = New CombData. For example, column B data would be V(I,2), and so forth. Of course, you might want to rename the data types to make them more representative of what you are doing.
In addition, if your data starts at row 2, merely start the iteration through V with I = 2 instead of I = 1.
EDIT2: In order to both overwrite the original, and also maintain the contents of the columns not being processed, the following modification will do that for Columns A, J and Z. You should be able to modify it for whatever columns you choose to process.
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long, J As Long, K As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1") '.Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
'Note the 10 below is the column we are summarizing by
J = WorksheetFunction.Match(.ColJ, WorksheetFunction.Index(V, 0, 10), 0)
For K = 1 To 26
Select Case K 'Decide which columns to copy over
Case 2 To 9, 11 To 25
vRes(I, K) = V(J, K)
End Select
Next K
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
This is assuming that Column J is the key and Column A doesn't need to be appended. If Column A needs to be combined as well (not always the same), you would simply need to add another for each loop to check if the data is there, and add it if not, as done for col 26 in the code.
Sub CombineData()
x = 2
Do Until Cells(x, 1) = "" 'loop through every row in sheet starting at 2 (1 will never be removed, since it is the first data)
x2 = 1
Do Until x2 = x
If Cells(x, 10) = Cells(x2, 10) Then 'this is comparing column J. If another column is the reference then change 10 to the column number
splt = Split(Cells(x, 26), ", ")
For Each s In splt 'check to see if data already in column z
If s = Cells(x2, 26) Then GoTo alreadyEntered
Next
Cells(x, 26) = Cells(x, 26) & ", " & Cells(x2, 26) 'append column z data to row x
alreadyEntered:
Rows(x2).Delete Shift:=xlUp 'delete duplicate row
x = x - 1 'to keep x at same row, since we just removed a row
Exit Do
Else
x2 = x2 + 1
End If
Loop
x = x + 1
Loop
End Sub
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub