-
Notifications
You must be signed in to change notification settings - Fork 0
/
InPlace.bas
140 lines (117 loc) · 5.91 KB
/
InPlace.bas
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
Attribute VB_Name = "InPlace"
Option Explicit
' Macros updated March 2013
' (c) 2007 by Stathis Kanterakis
Sub AlignInPlace()
Attribute AlignInPlace.VB_Description = "This is the description"
Attribute AlignInPlace.VB_ProcData.VB_Invoke_Func = " \n14"
Dim compA As String, compB As String, compA_cols As String, compB_cols As String, strA As String, strB As String
Dim start_str As String, msg_txt As String, msg_ret As String
Dim curr As Integer, start As Integer
compA = InputBox("Enter the first comparison column" & vbCrLf & "This should be the first column of the first table you wish to align and should contain sorted ids", "AlignInPlace", "A")
If Len(compA) = 0 Then: Exit Sub
compA_cols = InputBox("Enter the first range column" & vbCrLf & " This should be the last column of your first table", "AlignInPlace", compA)
If Len(compA_cols) = 0 Then: Exit Sub
compB = InputBox("Enter second comparison column" & vbCrLf & "This should be the first column of the second table you wish to align and should contain sorted ids", "AlignInPlace", rowToColumn(columnToRow(compA_cols) + 2))
If Len(compB) = 0 Then: Exit Sub
compB_cols = InputBox("Enter second range column" & vbCrLf & " This should be the last column of your second table", "AlignInPlace", compB)
If Len(compB_cols) = 0 Then: Exit Sub
start_str = InputBox("Starting row" & vbCrLf & "Enter the row where your data starts. For example, if you have headers in the first row, enter 2", "AlignInPlace", "2")
If Len(start_str) = 0 Then: Exit Sub
start = val(start_str)
curr = start
Application.StatusBar = "AlignInPlace is running..."
msg_txt = "I will align the ids of the first table (column " & UCase(compA) & " to column " & UCase(compA_cols) & ")" & vbCrLf & _
"against the ids of the second table (column " & UCase(compB) & " to column " & UCase(compB_cols) & ")," & vbCrLf & _
"starting at row " & curr & "." & vbCrLf & _
"This operation cannot be undone." & vbCrLf & "Continue?"
msg_ret = MsgBox(msg_txt, vbYesNoCancel, "AlignInPlace")
If msg_ret <> vbYes Then: Exit Sub
strA = Trim(Range(compA & curr))
strB = Trim(Range(compB & curr))
Range(compA & start).Select
Do While Len(strA) > 0 And StrComp(strA, "", vbTextCompare) <> 0
If Len(strB) > 0 And StrComp(strB, "", vbTextCompare) <> 0 Then
If IsNumeric(strA) And IsNumeric(strB) Then
If CDbl(strA) < CDbl(strB) Then
Range(compB & curr & ":" & compB_cols & curr).Select
Selection.Insert Shift:=xlDown
ElseIf CDbl(strA) > CDbl(strB) Then
Range(compA_cols & curr & ":" & compA & curr).Select
Selection.Insert Shift:=xlDown
End If
Else
If StrComp(strA, strB, vbTextCompare) < 0 Then
Range(compB & curr & ":" & compB_cols & curr).Select
Selection.Insert Shift:=xlDown
ElseIf StrComp(strA, strB, vbTextCompare) > 0 Then
Range(compA_cols & curr & ":" & compA & curr).Select
Selection.Insert Shift:=xlDown
End If
End If
End If
curr = curr + 1
strA = Trim(Range(compA & curr))
strB = Trim(Range(compB & curr))
Loop
Range(compA & start).Select
Application.StatusBar = False
End Sub
Sub MatchInPlace()
Dim compA As String, compB As String, compA_cols As String, compB_cols As String, strA As String, strB As String, maxRow As String
Dim start_str As String, msg_txt As String, msg_ret As String
Dim curr As Integer, start As Integer, max As Integer
compA = InputBox("Enter template column" & vbCrLf & "This is a column that contains blank rows which you wish to match in another table", "MatchInPlace", "A")
If Len(compA) = 0 Then: Exit Sub
compB = InputBox("Enter target column" & vbCrLf & " This is the first column of the table you wish to match to the template column", "MatchInPlace", rowToColumn(columnToRow(compA) + 2))
If Len(compB) = 0 Then: Exit Sub
compB_cols = InputBox("Enter target range column" & vbCrLf & " This is the last column of the target table", "MatchInPlace", compB)
If Len(compB_cols) = 0 Then: Exit Sub
start_str = InputBox("Starting row" & vbCrLf & "Enter the row where your data starts. For example, if you have headers in the first row, enter 2", "AlignInPlace", "2")
If Len(start_str) = 0 Then: Exit Sub
start = val(start_str)
curr = start
max = Range(compA & ":" & compA).SpecialCells(xlCellTypeLastCell).row
maxRow = InputBox("End row" & vbCrLf & "Enter the last row that contains data. An estimate has been given by default.", "AlignInPlace", max)
If Len(maxRow) = 0 Then: Exit Sub
max = val(maxRow)
Application.StatusBar = "MatchInPlace is running..."
msg_txt = "I will insert blank rows to the target table (column " & UCase(compB) & " to column " & UCase(compB_cols) & ")," & vbCrLf & _
"to match the template (column " & UCase(compA) & "), from row " & curr & " to row " & max & "." & vbCrLf & _
"This operation cannot be undone." & vbCrLf & "Continue?"
msg_ret = MsgBox(msg_txt, vbYesNoCancel, "MatchInPlace")
If msg_ret <> vbYes Then: Exit Sub
strA = Trim(Range(compA & curr))
strB = Trim(Range(compB & curr))
Range(compA & start).Select
Do While Len(strB) > 0 And curr < max
If Len(strA) < 1 Then
Range(compB & curr & ":" & compB_cols & curr).Select
Selection.Insert Shift:=xlDown
End If
curr = curr + 1
strA = Trim(Range(compA & curr))
strB = Trim(Range(compB & curr))
Loop
Range(compA & start).Select
Application.StatusBar = False
End Sub
Function rowToColumn(row As Integer) As String
Dim a, b, r As Integer
r = row - 1
a = r \ 26
b = r Mod 26
If r > 25 Then
rowToColumn = Chr(a + 64) & Chr(b + 65)
Else
rowToColumn = Chr(b + 65)
End If
End Function
Function columnToRow(column As String) As Integer
column = StrConv(column, vbUpperCase)
If Len(column) = 1 Then
columnToRow = Asc(column) - 64
ElseIf Len(column) = 2 Then
columnToRow = (Asc(Mid(column, 1, 1)) - 64) * 26 + Asc(Mid(column, 2, 1)) - 64
End If
End Function