• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

adjust this code

herofox

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

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