Hi Team,
I am adding all rows to collection, and from collection adding to Dictionary.
and then from Dictionary to worksheet. I saw one video on youtube Make Your VBA Code Run 1000 Faster Part-2.
its not pasting as expected. Thanks
Input Data:-
[/CODE]
I am adding all rows to collection, and from collection adding to Dictionary.
and then from Dictionary to worksheet. I saw one video on youtube Make Your VBA Code Run 1000 Faster Part-2.
its not pasting as expected. Thanks
Input Data:-
Book1 | ||||||||||
---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | |||
1 | 1270 | 1159 | 1919 | 1374 | 1426 | 1033 | 1043 | 1462 | ||
2 | 1162 | 1579 | 1946 | 1644 | 1951 | 1871 | 1054 | 1665 | ||
3 | 1851 | 1699 | 1776 | 1610 | 1722 | 1221 | 1702 | 1995 | ||
4 | 1552 | 1591 | 1047 | 1008 | 1338 | 1197 | 1745 | 1802 | ||
5 | 1337 | 1635 | 1836 | 1580 | 1724 | 1409 | 1749 | 1407 | ||
6 | 1426 | 1458 | 1998 | 1968 | 1773 | 1191 | 1006 | 1749 | ||
7 | 1838 | 1860 | 1446 | 1340 | 1744 | 1988 | 1862 | 1034 | ||
8 | 1902 | 1696 | 1644 | 1789 | 1518 | 1526 | 1772 | 1360 | ||
9 | 1138 | 1455 | 1817 | 1838 | 1280 | 1202 | 1058 | 1940 | ||
10 | 1777 | 1127 | 1231 | 1897 | 1430 | 1956 | 1653 | 1324 | ||
11 | 1618 | 1238 | 1582 | 1247 | 1648 | 1159 | 1709 | 1716 | ||
12 | 1159 | 1752 | 1806 | 1015 | 1510 | 1508 | 1160 | 1299 | ||
13 | 1074 | 1537 | 1772 | 1347 | 1380 | 1434 | 1411 | 1707 | ||
14 | 1894 | 1200 | 1820 | 1431 | 1593 | 1580 | 1059 | 1048 | ||
15 | 1612 | 1834 | 1243 | 1560 | 1103 | 1868 | 1646 | 1681 | ||
16 | 1606 | 1146 | 1088 | 1823 | 1221 | 1567 | 1350 | 1932 | ||
17 | 1660 | 1195 | 1783 | 1264 | 1448 | 1097 | 1870 | 1652 | ||
18 | 1339 | 1772 | 1653 | 1065 | 1825 | 1757 | 1279 | 1731 | ||
19 | 1219 | 1556 | 1223 | 1047 | 1502 | 1377 | 1053 | 1839 | ||
20 | 1966 | 1878 | 1877 | 1675 | 1826 | 1472 | 1347 | 1493 | ||
21 | 1545 | 1805 | 1728 | 1244 | 1986 | 1799 | 1919 | 1109 | ||
Sheet1 |
VBA Code:
[CODE=vba]Option Explicit
Sub ReadRows()
Dim coll As New Collection, i As Long
'Read Data to Collection - all rows
Dim rg As Range
Set rg = Range("A1").CurrentRegion
For i = 1 To rg.Rows.Count
coll.Add rg.Rows(i)
Next i
'Add Collection to Dictionary
ReadCollectionToDictionary coll
End Sub
Private Function ReadCollectionToDictionary(ByVal coll As Collection) As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To coll.Count
dict.Add i, coll(i)
Next i
Set ReadCollectionToDictionary = dict
WriteDictionaryToWorksheet dict
End Function
Private Sub WriteDictionaryToWorksheet(dict As Object)
Range("A1").CurrentRegion.ClearContents
Dim row As Long
row = 1
Cells(row, 1).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.keys)
Cells(row, 2).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.items)
End Sub