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
Title | # Comments | Views | Activity |
---|---|---|---|
Excel conditional formatting based on 'zero value' | 6 | 20 | |
hi all how do i achive this formula in condtional formatting excel | 6 | 19 | |
VLOOKUP | 6 | 18 | |
Excel - conditional formatting on several columns | 9 | 38 |
Join the community of 500,000 technology professionals and ask your questions.