i'm new to vba and i was trying to make a program to do add multiple items to a key.
Eg:
Table
Name Date Time
XYZ 20 4
ABC 21 5
XYZ 22 6
and then if the names are repeated, then column values to the previous one...like:
Name Date Time Date Time
XYZ 20 4 22 6
ABC 21 5
i've done sorting and adding the sum of duplicate values for a single item value but i'm finding it hard to do this for multivalued item. So plz do help out!!
Thank you!!
Sub t()
Application.DisplayAlerts = False
Dim Tempsheet As Worksheet
Dim c As Range
Set Tempsheet = ThisWorkbook.Sheets.Add
With ThisWorkbook.Sheets("sheet1")
rng = .UsedRange.Address
.UsedRange.Sort key1:=.Range("b1"), order1:=xlAscending, key2:=.Range("c1"), order2:=xlAscending, Header:=xlYes
.UsedRange.Columns(1).Copy
Tempsheet.Range("a1").PasteSpecial (xlPasteValues)
Tempsheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
For Each cell In Tempsheet.Range("a1:a" & Tempsheet.Range("a" & Rows.Count).End(xlUp).Row).Cells
i = i + 1
If i <> 1 Then
With .Range(rng)
Set c = .Find(what:=cell.Value, after:=.Range("a1"), LookIn:=xlValues, lookat:=xlWhole)
firstAddress = c.Address
If Not c Is Nothing Then
Do
j = j + 1
If j <> 1 Then
k = k + 1
.Range(c.Offset(0, 1), c.Offset(0, 2)).Copy
.Range(firstAddress).Offset(0, (k * 2) + 1).PasteSpecial (xlPasteValues)
.Range(firstAddress).Offset(-1, (k * 2) + 1) = "Date"
.Range(firstAddress).Offset(-1, (k * 2) + 2) = "Time"
c.EntireRow.ClearContents
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End If
j = 0
Next cell
.UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Tempsheet.Delete
End Sub
You are writing an elaborate program for something that is a basic part of the Excel functionality. It is called Pivot tables.
https://en.wikipedia.org/wiki/Pivot_table
http://www.excel-easy.com/data-analysis/pivot-tables.html
Related
I am using the code below and it works for filtering the unique name and totalting the value field. I recently have a need to expand upon the filtering of unique names to include other columns in the criteria. Please see the example output I am looking for. Any help would be appreciated.
Sub SUM()
Dim i, j, k As Integer
i = 2
j = 2
Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"
'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value
'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""
'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
'in column D and E
If Range("A" & i).Value = Range("A" & i - 1).Value Then
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
Else
flag = 1
While Range("D" & flag).Value <> ""
If Range("A" & i).Value = Range("D" & flag).Value Then
j = flag
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
flag = Range("D1").End(xlDown).Row
Else
j = 0
End If
flag = flag + 1
Wend
If j = 0 Then
Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
j = Range("E1").End(xlDown).Row
End If
End If
i = i + 1
Wend
MsgBox "End"
End Sub
Currently outputs like this:
Name Value Name Sum
A 1 A 13
A 2 B 7
B 1 C 3
B 3
C 2
A 1
B 2
A 3
B 1
A 2
A 4
C 1
I would like to have it export data like this example:
Name Code Date Value Name Code Date Sum
A 101 3/10/17 1 A 101 3/10/17 9
A 101 3/10/17 2 A 102 3/10/17 4
B 102 3/10/17 1 B 101 3/10/17 3
B 101 3/10/17 3 B 102 3/10/17 2
C 102 3/8/17 2 B 101 3/8/17 2
A 102 3/10/17 1 C 102 3/8/17 2
B 101 3/8/17 2 C 102 3/10/17 1
A 102 3/10/17 3
B 102 3/10/17 1
A 101 3/10/17 2
A 101 3/10/17 4
C 102 3/10/17 1
As long as your columns go A,B,C,D then F,G,H,I then below code should work. Let me know if it works for you.
Sub CountCodes()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim wbk As Workbook
Dim ws As Worksheet
Dim wsRow As Long, newRow As Long
Dim Names() As String
Dim Found As Boolean
Dim x As Integer, y As Integer, z As Integer, myCount As Integer, mySum As Integer
Dim Cell As Range
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
ReDim Names(0 To 0) As String
ReDim Codes(0 To 0) As String
ReDim Dates(0 To 0) As String
newRow = 1
With ws
'Find last row of data
wsRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop through Column A to fill array
For Each Cell In .Range(.Cells(2, 1), .Cells(wsRow, 1))
'Fill Names array
Found = (IsInArray(Cell.Value2, Names) > -1)
If Found = False Then
Names(UBound(Names)) = Cell.Value2
If Cell.Row <> wsRow Then
ReDim Preserve Names(0 To UBound(Names) + 1) As String
End If
End If
'Fill Codes array
Found = (IsInArray(Cell.Offset(0, 1).Value2, Codes) > -1)
If Found = False Then
Codes(UBound(Codes)) = Cell.Offset(0, 1).Value2
If Cell.Row <> wsRow Then
ReDim Preserve Codes(0 To UBound(Codes) + 1) As String
End If
End If
'Fill Dates array
Found = (IsInArray(Cell.Offset(0, 2).Value2, Codes) > -1)
If Found = False Then
Dates(UBound(Dates)) = Cell.Offset(0, 2).Value
If Cell.Row <> wsRow Then
ReDim Preserve Codes(0 To UBound(Dates) + 1) As String
End If
End If
Next
'Add Autofilter if off
If .AutoFilterMode = False Then
.Range("A1").AutoFilter
End If
For x = LBound(Names) To UBound(Names)
.Range("A1").AutoFilter Field:=1, Criteria1:=Names(x)
For y = LBound(Codes) To UBound(Codes)
.Range("B1").AutoFilter Field:=2, Criteria1:=Codes(y)
For z = LBound(Dates) To UBound(Dates)
.Range("C1").AutoFilter Field:=3, Criteria1:=Dates(z)
For Each Cell In .Range("A1:A" & wsRow).SpecialCells(xlCellTypeVisible)
myCount = myCount + 1
Next
If myCount > 1 Then
For Each Cell In .Range("D2:D" & wsRow).SpecialCells(xlCellTypeVisible)
mySum = mySum + Cell.Value2
Next
'Find last row in new data
newRow = newRow + 1
.Cells(newRow, 6) = Names(x)
.Cells(newRow, 7) = Codes(y)
.Cells(newRow, 8) = Dates(z)
.Cells(newRow, 9) = mySum
End If
myCount = 0
mySum = 0
Next z
Next y
Next x
.ShowAllData
End With
Erase Names
Erase Codes
Erase Dates
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
'http://stackoverflow.com/questions/10951687/how-to-search-for-string-in-an-array
'Boolean = (IsInArray(StringToFind, ArrayToSearch) > -1)
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
I used a pivot table in Excel 2016 to generate this view, since you are not opposed to using a Pivot Table. If Excel can do this out of the box, and you are happy with how it looks and behaves, there is no real need for custom VBA in this case.
Just do the following:
Highlight your data, then insert > pivot table
I placed the pivot table in cell F1 of Sheet 1
Add Name, Code, and Date to the Rows of the pivot table
Add Value to the Values of the pivot table. It should default to Sum.
Click on the pivot table, then in the pivot table tools > design tab in the ribbon, go to the "Layout" ribbon group:
On the Report Layout Dropdown:
Click "Show in Tabular Form"
Click "Repeat All Item Labels"
On the Subtotals Dropdown:
Click "Do Not Show Subtotals"
On the Grand totals Dropdown:
Click "off for rows and columns"
You could use Dictionary object:
Option Explicit
Sub ListTotals()
Dim c As Range, dataRng As Range
Dim key As Variant
Set dataRng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In dataRng
key = Join(c.Resize(,3), "|")
.Item(key) = .Item(key) + c.Offset(,4)
Next c
With dataRng.Resize(.Count)
.Offset(,5) = Application.Transpose(.Keys)
.Offset(,8) = Application.Transpose(.Items)
.Offset(,5).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|", FieldInfo:= Array(Array(1, 2), Array(3, 3))
End With
End With
End Sub
I am trying to create VBA code that copies and pastes data from Column B into the row directly beneath in Column A. I do not have great experience with VBA and so I am struggling to create such a code.
I would like to create a code that loops for an entire set of data in Columns A and B as shown in the attached picture.
So for example, B3 would get pasted into A4. B5 would get pasted into A6. And all the way down until the list was completed.
Thank you for any help!
The below code works quite good for your criteria.
rowNum = 3
Do While Trim(Range("A" & rowNum).Value) <> ""
Range("A" & (rowNum + 1)).Value = Range("B" & rowNum).Value
rowNum = rowNum + 2
Loop
Here is a simple example that will do what you ask.
For i = 2 To 10
If Range("A" & i) > "" And Range("A" & i + 1) = "" Then
Range("B" & i).Cut
Range("A" & i + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If
Next
Depending on what your data looks like, you will probably want to setup something more dynamic for the value of 'i'.
Use LastRowIndex from https://stackoverflow.com/a/71296/42346 to find the final row then iterate over the rows in column 2 placing the value in column 1 one row below the current row.
Sub iterate()
Dim r As Long
Dim c As Long
Dim endrow As Long
c = 2
endrow = LastRowIndex(ActiveSheet, c)
For r = 2 To endrow Step 1
If ActiveSheet.Cells(r, c).Value <> "" Then
ActiveSheet.Cells(r + 1, c - 1).Value = ActiveSheet.Cells(r, c).Value
End If
Next r
End Sub
Function LastRowIndex(ByVal w As Worksheet, ByVal col As Variant) As Long
Dim r As Range
Set r = Application.Intersect(w.UsedRange, w.Columns(col))
If Not r Is Nothing Then
Set r = r.Cells(r.Cells.Count)
If IsEmpty(r.Value) Then
LastRowIndex = r.End(xlUp).Row
Else
LastRowIndex = r.Row
End If
End If
End Function
I've what seems like a pretty simple application with looping and 'If..Then' statements but need some help on structuring it.
In very a basic example, I have a list numbers in column A and the values PM or AM listed in column B. I want to write a loop that will search every value in column B until the end of the data set, and add 12 to each value in column A each time column B has a value of PM. In a nutshell, it would look like this:
If column B = PM
then add 12 to its corresponding cell in column A
else move down to the next row and do the same thing until you reach an empty cell
There are many ways, here is a typical one:
Sub dural()
Dim i As Long
i = 1
Do While Cells(i, "B").Value <> ""
If Cells(i, "B").Value = "PM" Then
Cells(i, "A").Value = Cells(i, "A").Value + 12
End If
i = i + 1
Loop
End Sub
you can set it with For next loop and 2 variables. one for last row and the 2nd for the row count:
Sub Macro1()
Dim LastRow As String
Dim i As Integer
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 2).Value = "PM" Then Cells(i, 1).vlaue = Cells(i, 1).vlaue + 10
Next i
End
'
End Sub
This is another way to do this.
Option Explicit
Sub Add()
Dim rData As Range
Dim r As Range
Set rData = Cells(1, 1).CurrentRegion.Columns("B").Cells
For Each r In rData
If UCase$(r.Value) = "PM" Then
r.Offset(, -1).Value = r.Offset(, -1).Value + 12
End If
Next r
End Sub
Object doesnt support this property or method. Only happens on the .Paste section in this code. Please help, because I am perplexed. I have tried to simplify the code as much as posible to simply select the cell, copy the cell, select target, and paste. Something is missing here...
Sub AIM36DBOCompare()
Dim n As Integer
n = 2
Dim PasteCount As Integer
Dim Value1 As String
Dim Date1 As String
Dim c As Range
PasteCount = 41
Range("AD2:AD1000").Copy Destination:=Range("S41" & Lastrow)
Do While n <= 1000
If Cells(26, n) <> 0 Then
'--------------------------------------------
With Worksheets(1).Range("b2:b10000")
Set c = .Find(Cells(n, 26), LookIn:=xlValues)
If Not c Is Nothing Then
Do
Date1 = c.Offset(0, -1).Address
Value1 = c.Offset(0, 3).Address
If Abs(Cells(n, 25) - Range(Date1).Value) <= 10 Then
Range(Value1).Select
Selection.Copy
Cells(PasteCount, 17).Select
Selection.Paste
PasteCount = PasteCount + 1
Exit Do
End If
Set c = .Find(Cells(n, 26).Value, LookIn:=xlValues)
Loop While Not c Is Nothing
End If
End With
'--------------------------------------------
End If
If Cells(11, n) = 0 Then
Exit Do
End If
n = n + 1
Loop
End Sub
Or if you just want to copy the value, skip the whole select and paste:
Cells(PasteCount, 17).Value = Range(Value1).Value
You can't do Selection.Paste (As you have just observed). If you call Paste on the sheet, it will paste to your selection, try this instead
ActiveSheet.Paste
If I have all data in one very long column like this:
A
B
C
1
2
3
D
E
F
4
5
6
G
H
I
7
8
9
Is it possible to move data like this?
Column1 Column2 Column3 Column4 Column5 Column6
A B C 1 2 3
D E F 4 5 6
G H I 7 8 9
I tried paste special+transpose , but I have more than 10 thousands records , so it will take me too much time in using this method.
I'm new in excel and macro , thank you very much.
Edit:
I even tried to transpose all data into many columns then select the column I want to make them all into one column with this macro:
Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet
''''''''''''''''''''''''''''''''''''''''''
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column
'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0
'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"
For from_colndx = 1 To from_lastcol
from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
'If you're going to exceed 65536 rows
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox "This time you've gone to far"
Exit Sub
End If
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it will just join all column into one but not the column selected.
For Remou reference:
Here is the output:
A D G
B E H
C F I
1 4 7
2 5 8
3 6 9
You can look at something in these lines:
Sub TransposeColumn()
Dim rng As Range
Dim ws As Worksheet
Set rng = Worksheets("Input").UsedRange
Set ws = Worksheets("Output")
j = 1
k = 1
For i = 1 To rng.Rows.Count
If rng.Cells(i, 1) = vbNullString Then
j = j + 1
k = 1
Else
''ws.Cells(k, j) = rng.Cells(i, 1)
''EDIT
ws.Cells(j, k) = rng.Cells(i, 1)
k = k + 1
End If
Next
End Sub
This is how I do the same thing... it creates the new table in column C over...based on your example that there is a blank cell between each group of data:
Sub TransposeGroups()
Dim RNG As Range, Grp As Long, NR As Long
Set RNG = Range("A:A").SpecialCells(xlConstants)
NR = 1
For Grp = 1 To RNG.Areas.Count
RNG.Areas(Grp).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Grp
End Sub
This should work for any length of data and "groups" of up to 8500 within the data.
This also uses the AREAS method, but this overcomes the groups limitation by using subgroups, so it should work with any size dataset.
Sub TransposeGroups2()
'Uses the AREAS method and will work on any size data set
'overcomes the limitation of areas by working in subgroups
Dim RNG As Range, rngSTART As Range, rngEND As Range
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
SubGrp = 1
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp)
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants)
Do
For Itm = 1 To RNG.Areas.Count
RNG.Areas(Itm).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Itm
If rngEND.Row = LR Then Exit Do
Set rngSTART = rngEND.Offset(1)
SubGrp = SubGrp + 1
Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp)
Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants)
Loop
End Sub