#### herofox

##### Active Member
hello every body
pls i want to adjust this code ,because if the result the same Name .it should be to just one time without repetition if the same day and the same Hotel Name

Code:
``````Option Explicit

Sub abodahab_send_data()
Dim myArray        As Variant
Dim Arr            As Variant
Dim lr             As Long
Dim rw             As Long
Dim x              As Long
Dim r              As Long
Dim dmin           As Date
Dim dmax           As Date
Dim target         As Date
Dim data           As Worksheet
Dim send           As Worksheet
'____________________________________________
Set data = Worksheets("data")
Set send = Worksheets("Moda Show")
'____________________________________________
lr = data.Cells(Rows.Count, 7).End(xlUp).Row
myArray = data.Range("a2:l" & lr)
ReDim y(1 To lr + 3, 1 To 5)
'____________________________________________
dmin = Application.WorksheetFunction.Min(data.Range("g2:g" & lr).Value2)
dmax = Application.WorksheetFunction.Max(data.Range("g2:g" & lr).Value2)
target = dmin
'____________________________________________
Arr = UniqueListFromRange(data.Range("L1:L" & lr))
rw = 1
'____________________________________________
Do While target <= dmax
For r = 1 To UBound(Arr)
If y(rw, 1) <> "" Then rw = rw + 1
For x = 1 To lr - 1
If myArray(x, 12) = Arr(r) And myArray(x, 7) = target Then
y(rw, 1) = target
y(rw, 2) = "comb"
y(rw, 3) = myArray(x, 12)
y(rw, 4) = myArray(x, 8) & "+" & y(rw, 4)
y(rw, 5) = myArray(x, 1) + y(rw, 5)
End If
Next x
Next r
If y(rw, 1) <> "" Then rw = rw + 1
target = target + 1
Loop
If rw > 0 Then
For x = 1 To rw
If Right(y(x, 4), 1) = "+" Then y(x, 4) = Left(y(x, 4), Len(y(x, 4)) - 1)
Next x
send.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 5).Value = y()
MsgBox "Done"

End If

End Sub

Public Function UniqueListFromRange(rgInput As Range) As Variant
Dim d           As Object
Dim dataSet     As Variant
Dim rgArea      As Range
Dim x           As Long
Dim y           As Long

Set d = CreateObject("Scripting.Dictionary")

For Each rgArea In rgInput.Areas
dataSet = rgArea.Value
If IsArray(dataSet) Then
For x = 1 To UBound(dataSet)
For y = 1 To UBound(dataSet, 2)
If Len(dataSet(x, y)) <> 0 Then d(dataSet(x, y)) = Empty
Next y
Next x
Else
d(dataSet) = Empty
End If
Next rgArea

UniqueListFromRange = d.Keys
End Function``````

#### Attachments

• 151.3 KB Views: 3
• 79.5 KB Views: 4

#### p45cal

##### Well-Known Member
Try changing:
y(rw, 4) = myArray(x, 8) & "+" & y(rw, 4)
to:
If InStr(y(rw, 4), myArray(x, 8)) = 0 Then y(rw, 4) = myArray(x, 8) & "+" & y(rw, 4)

#### herofox

##### Active Member
thanks very much
it's now work as well