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
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