1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
|
Sub Sort_2_cols_to_grid()
' ********************************************
' ** Assumptions
' ********************************************
' ** - Data Starts in Row 23. Last Row is calculated by macro
' ** - Values in Column A and F are same
' ** - Values in Column C and H are same
' ** - Values are in columns A, B, C, F, G, H
' ********************************************
On Error GoTo skip1
Dim DataFirstRow As Long
Dim DataLastRow As Long
Dim DataCurrentRow As Long
Dim ResultFirstRow As Long
Dim ResultLastRow As Long
Dim ResultCurrentRow As Long
Dim ResultFirstCol As Long
Dim ResultLastCol As Long
Dim ResultCurrentCol As Long
Dim RowTitle As String
Dim ColTitle As String
Dim Result1 As String
Dim Result2 As String
If Range("B27") = "" Then GoTo skip1
DataFirstRow = 27
DataLastRow = [A65536].End(xlUp).Row
' Rows("1:1").Select
' Selection.Delete Shift:=xlUp
' Selection.Insert Shift:=xlDown
ResultFirstRow = 1 ' Row 1
ResultFirstCol = 6 ' Column F
'Range("G2:AT21").ClearContents
' First we set up the Row titles in row 1
' these row titles are from Column C (3) and H
' and will start from Column G(7)
If 1 = 2 Then
ResultCurrentRow = 1
ResultCurrentCol = 7
For DataCurrentRow = DataFirstRow To DataLastRow
ColTitle = Cells(DataCurrentRow, 3)
If IsError(Application.Match(ColTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultFirstRow, ResultCurrentCol)), 0)) Then
Cells(ResultCurrentRow, ResultCurrentCol) = ColTitle
ResultCurrentCol = ResultCurrentCol + 2
End If
Next DataCurrentRow
ResultLastCol = ResultCurrentCol - 1
Else
ResultLastCol = 54
ResultLastRow = 25
End If '1=2
' Next we set up the Row titles in Column F (6)
ResultCurrentRow = 2 - 1
ResultCurrentCol = 6
For DataCurrentRow = DataFirstRow To DataLastRow
RowTitle = Cells(DataCurrentRow, 1)
'If IsError(Application.Match(RowTitle, Range(Cells(ResultFirstRow, 6), Cells(ResultCurrentRow, 6)), 0)) Then
' ResultCurrentRow = ResultCurrentRow + 1
' Cells(ResultCurrentRow, 6) = RowTitle
'End If
' Next we pick up the data in a loop
' from Columns A (1), B (2), C (3), and G (7)
' Locate the result Row and Columns using Match
' and then Paste the Result Data
ColTitle = Cells(DataCurrentRow, 3)
ResultCurrentCol = Application.Match(ColTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultFirstRow, ResultLastCol)), 0)
ResultCurrentRow = Application.Match(RowTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultLastRow, ResultFirstCol)), 0)
'Cells(DataCurrentRow, 2).Copy
'Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1).Select
'ActiveSheet.Paste
'Cells(DataCurrentRow, 7).Copy
'Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol).Select
'ActiveSheet.Paste
Result1 = Cells(DataCurrentRow, 2)
Result2 = Cells(DataCurrentRow, 7)
'Check if Grid is empty
If IsEmpty(Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1)) = True Then
Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1) = "'" + Result1
Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol) = "'" + Result2
Else
'Check Second grid to the right
If IsEmpty(Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1 + 24)) = True Then
Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1 + 24) = "'" + Result1
Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol + 24) = "'" + Result2
Else
'Check Third grid (left bottom)
If IsEmpty(Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1)) = True Then
Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1) = "'" + Result1
Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol) = "'" + Result2
Else
'Check Fourth grid (right bottom)
If IsEmpty(Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1 + 24)) = True Then
Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1 + 24) = "'" + Result1
Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol + 24) = "'" + Result2
Else
MsgBox "All grids are full for this fixture"
End If
End If
End If
End If
Next DataCurrentRow
If 1 = 2 Then
For ResultCurrentCol = ResultFirstCol + 1 To ResultLastCol Step 2
Range(Cells(ResultFirstRow, ResultCurrentCol), Cells(ResultFirstRow, ResultCurrentCol + 1)).Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
Next ResultCurrentCol
End If '1=2
' centar grid delet character
Range("G2:BB25").Select
Selection.Replace What:=" '", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" """, Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" ยค", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Select
skip1:
End Sub
|
