Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Sub CopyData()
Dim strTmp As String
Dim strTmp1 As String
'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To Range("TABLEDATA").Columns.Count
For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value)
If strTmp <> "" Then
If Not (oDicTmp.Exists(strTmp)) Then
oDicTmp.Add strTmp, 1
End If
End If
Next nJ
Next nI
'------------------------------
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long
'nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
nCol = 6 'The number of columns is fixed
With Sheets("Sheet2")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
strTmp = Trim(vIn(i, j)) & vIn(i, j + 1)
strTmp1 = Left(vIn(i, j + 1), 5)
If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = vIn(i, j + 1)
.Add strTmp, 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / nCol, 0)
Dim nNextRow As Long
nNextRow = NextAvailableRow
With Sheets("Matched")
With .Range("A" & Trim(Str(nNextRow)))
If nNextRow = 1 Then
.Resize(, 3).Value = Array("Number", "Type", "")
End If
'Long added one if statement to check if the number of rows exceed 65536 rows
If n > 65536 Then
MsgBox "The number of rows is " & Trim(Str(n)) & " which exceeds 65536." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
If n = 0 Then
MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
.Offset(1).Resize(n, 3) = vOut
End If
End If
For j = 1 To nCol - 1
If nNextRow = 1 Then
.Offset(, j * 3).Resize(, 3).Value = Array("Number", "Type", "")
End If
.Offset(p + 1, (j - 1) * 3).Resize(n - (p * j), 3).Cut .Offset(1, j * 3)
Next j
End With
End With
End Sub
MatchedData.xls
Sub CopyData()
Dim strTmp As String
Dim strTmp1 As String
'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To Range("TABLEDATA").Columns.Count
For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value)
If strTmp <> "" Then
If Not (oDicTmp.Exists(strTmp)) Then
oDicTmp.Add strTmp, 1
End If
End If
Next nJ
Next nI
'------------------------------
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long
'nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
nCol = 6 'The number of columns is fixed
With Sheets("Sheet2")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 2 To UBound(vIn, 2) - 1 Step 2
strTmp = Trim(vIn(i, j)) & vIn(i, j + 1)
strTmp1 = vIn(i, j + 1)
If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = vIn(i, j + 1)
.Add strTmp, 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / nCol, 0)
Dim nNextRow As Long
nNextRow = NextAvailableRow
With Sheets("Matched")
With .Range("A" & Trim(Str(nNextRow)))
If nNextRow = 1 Then
.Resize(, 3).Value = Array("Number", "Type", "")
End If
'Long added one if statement to check if the number of rows exceed 65536 rows
If n > 65536 Then
MsgBox "The number of rows is " & Trim(Str(n)) & " which exceeds 65536." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
If n = 0 Then
MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
.Offset(1).Resize(n, 3) = vOut
End If
End If
For j = 1 To nCol - 1
If nNextRow = 1 Then
.Offset(, j * 3).Resize(, 3).Value = Array("Number", "Type", "")
End If
.Offset(p + 1, (j - 1) * 3).Resize(n - (p * j), 3).Cut .Offset(1, j * 3)
Next j
End With
End With
End Sub
Function NextAvailableRow()
Dim nResult As Long
Dim nR As Long
For nR = 1 To 65535
If Cells(nR, 1).Value = "" Then
If nR > 1 Then
NextAvailableRow = nR - 1
Else
NextAvailableRow = nR
End If
Exit Function
End If
Next nR
NextAvailableRow = 1
End Function
Sub CopyData()
Dim strTmp As String
Dim strTmp1 As String
'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To Range("TABLEDATA").Columns.Count
For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value)
If strTmp <> "" Then
If Not (oDicTmp.Exists(strTmp)) Then
oDicTmp.Add strTmp, 1
End If
End If
Next nJ
Next nI
'------------------------------
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long
'nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
nCol = 6 'The number of columns is fixed
With Sheets("Sheet2")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
strTmp = Trim(vIn(i, j)) & vIn(i, j + 1)
strTmp1 = Left(vIn(i, j + 1), 5)
If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = vIn(i, j + 1)
.Add strTmp, 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / nCol, 0)
Dim nNextRow As Long
nNextRow = NextAvailableRow
With Sheets("Matched")
With .Range("A" & Trim(Str(nNextRow)))
If nNextRow = 1 Then
.Resize(, 2).Value = Array("Number", "Type")
End If
'Long added one if statement to check if the number of rows exceed 65536 rows
If n > 65536 Then
MsgBox "The number of rows is " & Trim(Str(n)) & " which exceeds 65536." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
If n = 0 Then
MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
Exit Sub
Else
.Offset(1).Resize(n, 3) = vOut
End If
End If
For j = 1 To nCol - 1
If nNextRow = 1 Then
.Offset(, j * 2).Resize(, 2).Value = Array("Number", "Type", "")
End If
.Offset(p + 1, (j - 1) * 2).Resize(n - (p * j), 2).Cut .Offset(1, j * 2)
Next j
End With
End With
End Sub
Function NextAvailableRow()
Dim nResult As Long
Dim nR As Long
For nR = 1 To 65535
If Cells(nR, 1).Value = "" Then
If nR > 1 Then
NextAvailableRow = nR - 1
Else
NextAvailableRow = nR
End If
Exit Function
End If
Next nR
NextAvailableRow = 1
End Function
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.