I need a VBA code for a simple copy and (paste) transpose row data and results looks like below
Row data
Final results
Kindly help me.
I hope you accept answer and upvote
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = Sheet1.Range("A1").CurrentRegion
Dim dicMaster As Object
Set dicMaster = VBA.CreateObject("Scripting.Dictionary")
Dim lRowLoop As Long
For lRowLoop = 1 To rng.Rows.Count
Dim vLeft As Variant
vLeft = rng.Cells(lRowLoop, 1)
Dim vRight As Variant
vRight = rng.Cells(lRowLoop, 2)
Dim dicSub As Object
If Not dicMaster.exists(vLeft) Then
Set dicSub = VBA.CreateObject("Scripting.Dictionary")
dicMaster.Add vLeft, dicSub
End If
Set dicSub = dicMaster.Item(vLeft)
dicSub.Add dicSub.Count, vRight
Next
'* find the widest
Dim lWidest As Long
lWidest = 0
Dim vKeyLoop As Variant
For Each vKeyLoop In dicMaster.Keys
Dim lCount As Long
lCount = dicMaster(vKeyLoop).Count
If lWidest < lCount Then lWidest = lCount
Next
'* so now dimension results
ReDim vResults(1 To dicMaster.Count, 1 To lWidest + 1) As Variant
Dim lRowIndex As Long
For Each vKeyLoop In dicMaster.Keys
lRowIndex = lRowIndex + 1
vResults(lRowIndex, 1) = vKeyLoop
Set dicSub = dicMaster.Item(vKeyLoop)
Dim lColIndex As Long
lColIndex = 2
Dim vItemLoop As Variant
For Each vItemLoop In dicSub.Items
vResults(lRowIndex, lColIndex) = vItemLoop
lColIndex = lColIndex + 1
Next vItemLoop
Next
Sheet2.Cells(1, 1).Resize(dicMaster.Count, lWidest + 1) = vResults
End Sub
Related
I cannot paste anywhere besides column "A" I have tried changing the column letter, but I get an error code saying the "copy/paste cell are not the same size".
Sub HEA_Filter_Names()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
You cannot paste an EntireRow starting anywhere else than column A.
You can try this instead:
Intersect(rngCells.EntireRow, rngCells.Parent.UsedRange).Copy wsDest.Range("F" & DestNoRows)
I have an issue which I use a lot of manual time on currently.
I have following simple data:
And I wish to convert all the accounts downwards with the name next to the accounts in another column. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)
This is an example of my wish scenario..
Hope you are able to help..
Thanks a lot
Kristoffer
The following short macro will take data from Sheet1 and output records in Sheet2:
Sub DataReorganizer()
Dim i As Long, j As Long, N As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 2 To N
v1 = s1.Cells(i, 1)
ary = Split(s1.Cells(i, 2), ";")
For Each a In ary
s2.Cells(j, 1).Value = v1
s2.Cells(j, 2).Value = a
j = j + 1
Next a
Next i
End Sub
Input:
and output:
Try this
Option Explicit
Sub Test()
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
Set rng = rng.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
Dim vPaste
Dim lTotalRows As Long
Dim lPass As Long
For lPass = 0 To 1
Dim rowLoop As Excel.Range
For Each rowLoop In rng.Rows
Dim sName As String
sName = rowLoop.Cells(1, 1)
Dim sAccounts As String
sAccounts = rowLoop.Cells(1, 2)
Dim vSplitAccounts As Variant
vSplitAccounts = VBA.Split(sAccounts, ";")
If lPass = 0 Then
lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
Else
Dim vLoop As Variant
For Each vLoop In vSplitAccounts
lTotalRows = lTotalRows + 1
vPaste(lTotalRows, 1) = sName
vPaste(lTotalRows, 2) = vLoop
Next vLoop
End If
Next
If lPass = 0 Then
ReDim vPaste(1 To lTotalRows, 1 To 2)
lTotalRows = 0
End If
Next
ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
Dim rngPaste As Excel.Range
Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
rngPaste.Value2 = vPaste
End Sub
I have written the following code, which I was hoping to use to look up values from columns 21 through to the last row in another sheet and return them to this sheet based on a value in column A in this sheet and column B in the other sheet.
When I use the code below I get an worksheet error. Could you please tell me why?
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
wbMVRVFile.Worksheets.Add().Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set wsMvFile = wbMVRVFile.ActiveSheet
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For wsColumn = 21 To lastColumn
For i = 2 To y
wsMvFile.Columns(wsColumn).Cells(i) = Application.Index(wsMvOld.Range(wsColumn), Application.Match(wsMvFile.Range("A" & i), wsMvOld.Range("B:B"), 0))
Next i
Next wsColumn
End Sub
Thanks for your help!
This untested, but it replaces the worksheet function to vba find method.
Private Sub Worksheet_Activate()
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
Set wsMvFile = wbMVRVFile.Worksheets.Add()
wsMvFile.Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For i = 2 To y
Dim rng As Range
Set rng = sMvOld.Range("B:B").Find(wsMvFile.Range("A" & i))
For wsColumn = 21 To lastColumn
If Not rng Is Nothing Then
wsMvFile.Columns(wsColumn).Cells(i).Value = wsMvOld.Cells(rng.Row, wsColumn)
Else
wsMvFile.Columns(wsColumn).Cells(i).Value = 0
End If
Next wsColumn
Next i
End Sub
I need to pull the unique names from column A on Sheet1 and on Sheet2 display only one of each name and the number of times it appeared. The names on Sheet 1 change daily, so I can't hard code any of them in.
Sheet1:
A
Joe
Joe
Paul
Steve
Steve
Steve
Sheet2:
A B
Joe 2
Paul 1
Steve 3
Code I have so far:
Sub testing()
Dim data As Variant, temp As Variant
Dim obj As Object
Dim i As Long
Set obj = CreateObject("scripting.dictionary")
data = Selection
For i = 1 To UBound(data)
obj(data(i, 1) & "") = ""
Next
temp = obj.keys
Selection.ClearContents
Selection(1, 1).Resize(obj.count, 1) = Application.Transpose(temp)
End Sub
However, this is producing an error by itself.
It's giving me:
Joe
Joe
Paul
Steve
Consider using .RemoveDuplicates:
Sub CountUniques()
Dim r1 As Range, r2 As Range, r As Range
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set r1 = Sheets("Sheet1").Columns(1).Cells
Set r2 = Sheets("Sheet2").Range("A1")
r1.Copy r2
r2.EntireColumn.RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In r2.EntireColumn.Cells
v = r.Value
If v = "" Then Exit Sub
r.Offset(0, 1).Value = wf.CountIf(r1, v)
Next r
End Sub
I wouldn't use a dictionary, personally, I'd do something like this -
Sub countem()
Dim origin As Worksheet
Set origin = Sheets("Sheet1")
Dim destination As Worksheet
Set destination = Sheets("Sheet2")
Dim x As Integer
x = origin.Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Integer
y = 1
Dim strName As String
Dim rngSearch As Range
For i = 1 To x
strName = origin.Cells(i, 1).Value
Set rngSearch = destination.Range("A:A").Find(strName, , xlValues, xlWhole)
If Not rngSearch Is Nothing Then
rngSearch.Offset(, 1) = rngSearch.Offset(, 1) + 1
Else: destination.Cells(y, 1) = strName
destination.Cells(y, 2) = 1
y = y + 1
End If
Next
End Sub
Just run through the origin searching for it on the destination, if found count++, otherwise add it.
A more verbose answer if you insisted on using the dictionary object and if perhaps you had more data processing to do.
' Create Reference to Microsoft Scripting Runtime
' In VBE -> Tools -> References -> Microsoft Scripting Runtime
Option Explicit
Public Sub UniqueItems()
Dim rngInput As Range, rngOutput As Range
Dim vUniqueList As Variant
Set rngInput = ThisWorkbook.Worksheets(1).Range("A:A")
Set rngOutput = ThisWorkbook.Worksheets(2).Range("A:B")
vUniqueList = GetUniqueItems(rngInput)
rngOutput.ClearContents
rngOutput.Resize(UBound(vUniqueList, 1), UBound(vUniqueList, 2)).Value = vUniqueList
End Sub
Private Function GetUniqueItems(vList As Variant) As Variant
Dim sKey As String
Dim vItem As Variant
Dim oDict As Dictionary
If IsObject(vList) Then vList = vList.Value
Set oDict = New Dictionary
For Each vItem In vList
sKey = Trim$(vItem)
If sKey = vbNullString Then Exit For
AddToCountDict oDict, sKey
Next vItem
GetUniqueItems = GetDictData(oDict)
End Function
Private Sub AddToCountDict(oDict As Dictionary, sKey As String)
Dim iCount As Integer
If oDict.Exists(sKey) Then
iCount = CInt(oDict.Item(sKey))
oDict.Remove (sKey)
End If
oDict.Add sKey, iCount + 1
End Sub
Private Function GetDictData(oDict As Dictionary) As Variant
Dim i As Integer
Dim vData As Variant
If oDict.Count > 0 Then
ReDim vData(1 To oDict.Count, 1 To 2)
For i = 1 To oDict.Count
vData(i, 1) = oDict.Keys(i - 1)
vData(i, 2) = oDict.Items(i - 1)
Next i
Else
'return empty array on fail
ReDim vData(1 To 1, 1 To 2)
End If
GetDictData = vData
End Function
Gary's Students solution definitely cleaner!
I set a Public Type named "Info" as following
Public Type info
nAtt As Integer
nObs As Integer
rngData As Range
End Type
I wrote a function aim to return 3 objects when input the range for the header (nAtt: number of attribute; nObs: number of observations; rngData: range of the corresponding core data)
Public Function GetDatasetInfo(rng As Range) As info
Dim sets As info
Dim rowRef1 As Integer
rowRef1 = rng.Row
Dim colRef1 As Integer
colRef1 = rng.Column
Dim colRef2 As Integer
colRef2 = colRef1 + rng.Columns.Count - 1
Dim nAtt As Integer
nAtt = rng.Columns.Count
Dim nObs As Integer
Dim rngOutput As Range
If (Cells(rowRef1 + 1, rng.Column).Value = "") Then
nObs = 0
Set rngOutput = rng
Else
nObs = rng.Offset(1, 0).End(xlDown).Row - rowRef1
Set rngOutput = Range(Cells(rowRef1 + 1, colRef1), _
Cells(rowRef1 + nObs, colRef2))
End If
With sets
.nAtt = nAtt
.nObs = nObs
.rngData = rngOutput
End With
GetDatasetInfo = sets
End Function
And the following is the usage of the data:
Sub Main()
Dim rng As Range
Set rng = Range("rng1")
Dim v1 As info
v1 = GetDatasetInfo(rng)
MsgBox v1.nObs
v1.rngData.Select
End Sub
The code run well without adding .rngData = rngOutput in the function. And the error message indicate this line has something wrong.
Please advice. Many thanks for your help.