비슷한 그룹으로 묶기

Question

나는 열 b를 반복하면서 현재 셀의 첫 번째 단어가 다른 셀의 첫 단어와 같은지 확인하고 다른 단어의 첫 단어가 다른 단어의 첫 단어와 같은지 확인하기 위해 두 개의 for 루프를 사용합니다 따라서 유사한 항목을 그룹화합니다. 그러나 내가 찾은 일치 항목을 복사하여 붙여 넣기 할 때 비교 대상인 원래의 셀이 아니라 일치 항목을 복사하여 붙여 넣기 만합니다. 그룹화에서 일치 항목과 원본 셀을 갖고 싶습니다. 그러나 코드를 수정할 수있는 위치가 확실하지 않으므로 그렇게 할 것입니다. 나는 오히려 어떤 도움을 주시면 감사하겠습니다.

Sub FuzzySearch() 

Dim WrdArray1() As String, WrdArray2() As String, i As Long, Count As Long, Rng1 As Range 
Dim WS As Worksheet, positionx As Long, positiony As Long 
Dim rng2 As Range 

    Set WS = ThisWorkbook.ActiveSheet 
    With WS 
     Set Rng1 = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row) 
    End With 

For i = 1 To Rng1.Rows.Count 
With Columns("B") 
    .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas).Activate 
End With 

position = 1 

For j = 1 To Rng1.Rows.Count 

WrdArray1 = Split(ActiveCell.Value, " ") 
ActiveCell.Offset(1).Activate 
WrdArray2 = Split(ActiveCell.Value, " ") 

If UBound(WrdArray2) < 0 Then 

    End 
End If 

If WrdArray1(0) = WrdArray2(0) Then 
    ActiveCell.Copy Destination:=ActiveSheet.Range("C" & position) 
    position = position + 1 
    Count = Count + 1 
End If 

Next j 

Next i 



End Sub 

Answer 1

당신이 배열을 전송 한 후 배열의 혼합물을 사용하고 아마 루프 내 (비교기 포함) 최종 출력 배열 중 하나를 채울 쉽고 덜 혼란 스러울 것이다 범위되고 있음을 감안할 때 단일 명령으로 워크 시트.

그러나 Excel에서 모든 '무거운 짐을 털어 내기'를 수행하는 다음 접근 방식을 고려해보십시오. 코드 줄 수는 같지만 사용자 정보를 위해 주석을 달았습니다. 이것은 루프에 배열을 채우고이를 Range로 전송하는 것을 보여줍니다. 상황에 맞게 다양한 변수를 변경하십시오.

Sub grpAndCount() 

Dim ws As Worksheet 
Dim strow As Long, endrow As Long, stcol As Long 
Dim coloffset As Long, r As Long 
Dim newstr As String 
Dim drng As Range 
Dim strArr() As String 

'Data start r/c 
strow = 6 'Row 6 
stcol = 2 'Col B 

'Offset no of Cols from Data to place results 
coloffset = 2 

Set ws = Sheets("Sheet1") 

    With ws 
     'find last data row 
     endrow = Cells(Rows.Count, stcol).End(xlUp).Row 

      'for each data row 
      For r = strow To endrow 
       'get first word 
       newstr = Left(.Cells(r, stcol), InStr(.Cells(r, stcol), " ")-1) 
       'put string into array 
       ReDim Preserve strArr(r - strow) 
       strArr(r - strow) = newstr 
      Next r 

     'put array to worksheet 
     Set drng = .Range(.Cells(strow, stcol + coloffset), .Cells(endrow, stcol + coloffset)) 
     drng = Application.Transpose(strArr) 

     'sort newly copied range 
     drng.Sort Key1:=.Cells(strow, stcol + coloffset), Order1:=xlAscending, Header:=xlNo 

     'provide a header row for SubTotal 
     .Cells(strow - 1, stcol + coloffset) = "Header" 

     'resize range to include header 
     drng.Offset(-1, 0).Resize(drng.Rows.Count + 1, 1).Select 

     'apply Excel SubTotal function 
     Application.DisplayAlerts = False 
     Selection.Subtotal GroupBy:=1, Function:=xlCount, Totallist:=Array(1) 
     Application.DisplayAlerts = True 

     'remove 'Header' legend 
     .Cells(strow - 1, stcol + coloffset) = "" 
    End With 

End Sub