Consulting

Results 1 to 11 of 11

Thread: How convert this code to a macro?

  1. #1

    How convert this code to a macro?

    How do I convert this code to a macro?


    [VBA]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myrange, a, b As Range, rep(150) As Integer
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    rr = Target.Row
    x = [B1].Offset(rr - 1, 0)
    '=======================================================
    Set myrange = Range("B14:B18")
    '=======================================================
    Range("B14:K18").Interior.Pattern = xlNone
    i = 0
    '=======================================================
    Columns("k").ClearContents
    For Each s In myrange
    y = s.Value
    If y = x Then
    i = i + 1
    Range("B" & s.Row, "J" & s.Row).Interior.ColorIndex = 42
    rep(i) = s.Row
    End If
    Next s
    sum_nj = 0: chg = 0
    For j = 1 To i
    Set a = Range("H" & rep(j))

    For nj = 1 To i
    Set b = Range("J" & rep(nj))
    Set U = Range("K" & rep(nj))
    If b.Value <> a.Value Then chg = 1: b.Interior.ColorIndex = 3
    If b.Value <> a.Value Then chg = 1: U.Interior.ColorIndex = 36
    Next nj

    Next j


    '''''''
    If chg <> 0 Then
    For j = 1 To i
    sum_nj = sum_nj + Range("G" & rep(j)).Value
    Next j
    End If
    If sum_nj <> 0 Then Range("k" & rep(1)).Value = sum_nj

    ErrHandler:
    Application.EnableEvents = True
    End Sub[/VBA]

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    It already is a macro. Maybe you want to run it multiple times?

    Please add VBA code tags when you post code. Structure makes your code easier to read and to troubleshoot. You might want to add Option Explicit so that it will prompt you to Dim your variables. You can add that as an option in the VBE tools.

    In a module:
    [VBA]Option Explicit

    Sub Macro2010(ByVal Target As Range)
    Dim myrange, a, b As Range, rep(150) As Integer
    Dim rr As Long, x As Variant, y As Variant, i As Long
    Dim s As Range, sum_nj As Variant, chg As Variant, j As Long
    Dim nj As Variant, U As Variant

    On Error GoTo ErrHandler
    Application.EnableEvents = False
    rr = Target.Row
    x = [B1].Offset(rr - 1, 0)
    '=======================================================
    Set myrange = Range("B14:B18")
    '=======================================================
    Range("B14:K18").Interior.Pattern = xlNone
    i = 0
    '=======================================================
    Columns("k").ClearContents
    For Each s In myrange
    y = s.Value
    If y = x Then
    i = i + 1
    Range("B" & s.Row, "J" & s.Row).Interior.ColorIndex = 42
    rep(i) = s.Row
    End If
    Next s
    sum_nj = 0: chg = 0
    For j = 1 To i
    Set a = Range("H" & rep(j))
    For nj = 1 To i
    Set b = Range("J" & rep(nj))
    Set U = Range("K" & rep(nj))
    If b.Value <> a.Value Then chg = 1: b.Interior.ColorIndex = 3
    If b.Value <> a.Value Then chg = 1: U.Interior.ColorIndex = 36
    Next nj
    Next j

    '''''''
    If chg <> 0 Then
    For j = 1 To i
    sum_nj = sum_nj + Range("G" & rep(j)).Value
    Next j
    End If
    If sum_nj <> 0 Then Range("k" & rep(1)).Value = sum_nj

    ErrHandler:
    Application.EnableEvents = True
    End Sub
    [/VBA]

    Your worksheet event code is then:
    [VBA]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Macro2010 Target
    End Sub[/VBA]

  3. #3
    thank u , but I mean another :
    I want a macro that combines the quantity of each model and then leave items without details of packing sheet("aa")
    can u see my file
    Attached Files Attached Files

  4. #4
    no answer!!!!!!??

  5. #5
    is no any one will help?

  6. #6
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    Have you looked at the Excel function "Sumproduct"?
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  7. #7
    Yes, but the problem still exists. I want to delete duplicate rows of the column (a) and values added ​​in the rows of duplicate rows of each row to the row that he repeats.
    see my file then you will know

  8. #8
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    How do we tell what is duplicated? From your data, you have highlighted 4 rows which are not similar. In each case the Style No. is different.

    I'm having some difficulty in following your request as the title suggested you wanted to "turn this code into a macro" but it eventually seems that you want to find and delete duplicates and add the value of the duplicated row to the original row. I can only assume you require the Ctn No's to be added.

    Can you please take the time to explain in better detail what you are chasing here?
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  9. #9
    I changed the code to a macro is not working and what is the problem?


    Quote Originally Posted by Kenneth Hobs
    It already is a macro. Maybe you want to run it multiple times?

    Please add VBA code tags when you post code. Structure makes your code easier to read and to troubleshoot. You might want to add Option Explicit so that it will prompt you to Dim your variables. You can add that as an option in the VBE tools.

    In a module:
    [vba]Option Explicit

    Sub Macro2010(ByVal Target As Range)
    Dim myrange, a, b As Range, rep(150) As Integer
    Dim rr As Long, x As Variant, y As Variant, i As Long
    Dim s As Range, sum_nj As Variant, chg As Variant, j As Long
    Dim nj As Variant, U As Variant

    On Error GoTo ErrHandler
    Application.EnableEvents = False
    rr = Target.Row
    x = [B1].Offset(rr - 1, 0)
    '=======================================================
    Set myrange = Range("B14:B18")
    '=======================================================
    Range("B14:K18").Interior.Pattern = xlNone
    i = 0
    '=======================================================
    Columns("k").ClearContents
    For Each s In myrange
    y = s.Value
    If y = x Then
    i = i + 1
    Range("B" & s.Row, "J" & s.Row).Interior.ColorIndex = 42
    rep(i) = s.Row
    End If
    Next s
    sum_nj = 0: chg = 0
    For j = 1 To i
    Set a = Range("H" & rep(j))
    For nj = 1 To i
    Set b = Range("J" & rep(nj))
    Set U = Range("K" & rep(nj))
    If b.Value <> a.Value Then chg = 1: b.Interior.ColorIndex = 3
    If b.Value <> a.Value Then chg = 1: U.Interior.ColorIndex = 36
    Next nj
    Next j

    '''''''
    If chg <> 0 Then
    For j = 1 To i
    sum_nj = sum_nj + Range("G" & rep(j)).Value
    Next j
    End If
    If sum_nj <> 0 Then Range("k" & rep(1)).Value = sum_nj

    ErrHandler:
    Application.EnableEvents = True
    End Sub
    [/vba]

    Your worksheet event code is then:
    [vba]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Macro2010 Target
    End Sub[/vba]

  10. #10
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    What is the error message and to which line does it refer to?
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  11. #11
    or all, has helped some of the brothers; and this code

    [vba]Sub Macro2010()

    With ActiveSheet
    Application.ScreenUpdating = False
    Dim myrange, A, b As Range, rep(100) As Integer
    FRI = Range("A10").Value + 12
    Set myrange = Range("B13", "B" & FRI)
    Range("B" & 13, "J" & FRI + 1).Interior.Pattern = xlNone: [A:A].Interior.Pattern = xlNone
    [j:j].ClearContents
    For Each f In myrange
    SUM_NJ = 0
    i = 0
    For Each s In myrange
    If s.Value = f.Value Then
    i = i + 1
    rep(i) = s.Row
    Range("j" & s.Row).Interior.ColorIndex = 4
    SUM_NJ = SUM_NJ + Range("G" & rep(i)).Value
    If Range("G" & rep(1)).Value > 0 Then Range("A" & s.Row, "i" & s.Row).Interior.ColorIndex = 36 ' تلوين عند وجود ارقام
    End If
    Next s
    If SUM_NJ <> 0 Then
    Range("J" & rep(1)).Value = SUM_NJ
    For K = 2 To i
    Range("a" & rep(K), "i" & rep(K)).Interior.ColorIndex = 3
    Next K

    End If

    Next f
    End With

    Dim h As Long
    Lastrow = Cells(Rows.Count, "J").End(xlUp).Row + 100
    For h = Lastrow To 13 Step -1
    With ActiveSheet
    If .Cells(h, "J").Value2 = Empty Then
    .Rows(h).Delete
    Range("G13:G100").Value = Range("J13:J100").Value
    End If
    End With
    Next h
    end sub[/vba]
    Last edited by Aussiebear; 06-16-2011 at 02:45 PM. Reason: Applied VBA tags to code

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •