0 votes
in VBA by Beginner (36 points)
edited by

hi, everyone,

I hope somebody can help me by adjusting my code if is  possible. I have a lot of data in sheet1. Some of the data is repeated in the brand column and I transfer data to sheet2 using an input box based on column A in sheet1, then paste the data in sheet2, and insert the total row to sum quantity.

sheet1

sheet2

 

I crossed posted in this forum. Nobody has answered me so far, so I'm hoping for an answer in this forum. 

https://www.mrexcel.com/board/threads/copy-specific-data-from-sheet-to-another-use-by-input-box-and-insert-total-of-row-each-brand.1133125/#post-5481920

 

This  is  my  code. I hope somebody can fix it. 

Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
    ss = InputBox(" enter", "search")
        If CStr(xRg(K).Value) = "SS" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

1 Answer

+1 vote
by Skilled (670 points)
edited by
 
Best answer

Here is an improved version of my previous answer. The Collection of CODE items is more efficiently defined, and an InputBox permits the Collection to be trimmed. If this version is satisfactory, please click the Vote up-arrow.

Sub MoveRowBasedOnCellValue()
    Dim xRg As Range, xCell As Range
    Dim I As Long, J As Long, K As Long, xColor As Long
    Dim x As Variant, xTotal As Variant
    Dim bDone As Boolean
    Dim msg As String, ans As String, xA() As String
    Dim C As New Collection
    With Worksheets("Sheet1")
        I = .UsedRange.Rows.Count
        If I < 2 Then Exit Sub
        Set xRg = .Range("A2:A" & I)
    End With
    For Each xCell In xRg ' collect sorted values
        x = xCell.Value
        bDone = False
        For K = 1 To C.Count
            If x < C.Item(K) Then
                C.Add Item:=x, Key:=CStr(x), Before:=K
                bDone = True
                Exit For
            ElseIf x = C.Item(K) Then
                bDone = True
                Exit For
            End If
        Next K
        If Not bDone Then C.Add Item:=x, Key:=CStr(x)
    Next xCell
    msg = "Enter one or more CODE value(s) to be Totaled. " & vbNewLine _
        & "Use a comma to separate multiple values." & vbNewLine _
        & "Example: BS1200R20,BS1400R20,..." & vbNewLine _
        & "Or enter ALL to Total ALL CODE values."
    ans = Trim(InputBox(msg, "Enter CODE value(s)"))
    If ans = vbNullString Then Exit Sub
    If UCase(ans) <> "ALL" Then
        xA = Split(ans, ",")
        For Each x In C ' keep only input values
            bDone = False
            For I = 0 To UBound(xA)
                bDone = (x = Trim(xA(I)))
                If bDone Then Exit For
            Next I
            If Not bDone Then C.Remove Index:=CStr(x)
        Next x
    End If
    Application.ScreenUpdating = False
    Worksheets("Sheet2").Activate
    With ActiveSheet.UsedRange
        .ClearContents
        .Interior.ColorIndex = xlColorIndexNone
    End With
    Worksheets("Sheet1").Range("A1").EntireRow.Copy Destination:=Range("A1")
    xColor = Range("A1").Interior.Color
    J = 1
    For K = 1 To C.Count ' prepare Totals
        xTotal = 0
        For Each xCell In xRg
            If xCell.Value = C.Item(K) Then
                J = J + 1
                xCell.EntireRow.Copy Destination:=Range("A" & J)
                xTotal = xTotal + CLng(xCell.Offset(0, 2).Value)
            End If
        Next xCell
        J = J + 1
        Range("A" & J).Value = C.Item(K)
        Range("B" & J).Value = "TOTAL"
        Range("C" & J).Value = xTotal
        Range("A" & J & ":" & "C" & J).Interior.Color = xColor
    Next K
    If UCase(ans) <> "ALL" Then
        On Error Resume Next
            For I = 0 To UBound(xA) ' identify erroneous input values
                x = C.Item(Trim(xA(I)))
                If Err <> 0 Then
                    J = J + 2
                    Range("A" & J).Value = Trim(xA(I))
                    Range("B" & J).Value = "TOTAL"
                    Range("C" & J).Value = 0
                    Range("A" & J & ":" & "C" & J).Interior.Color = xColor
                    Err.Clear
                End If
            Next I
        On Error GoTo 0
    End If
    Range("A1").Activate
    Application.ScreenUpdating = True
End Sub

 

by Beginner (36 points)
well done  , jwoolly   could  adjust  by  use  inputbox  to  choose some  data  based  on column  a  in  sheet 1    instead of copy  all data
by Skilled (670 points)
See the improved version in my revised Answer above.
by Beginner (36 points)
thanks jwolly  the  changes are  flexible    and  perfect     i appreciate  that
by Skilled (670 points)
edited by

I changed two lines of the code in the Answer posted above.

Before: 
    Range("A1").CurrentRegion.ClearContents
    Range("A:C").Interior.ColorIndex = xlColorIndexNone
After: 
    With ActiveSheet.UsedRange
        .ClearContents
        .Interior.ColorIndex = xlColorIndexNone
    End With

 

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

ParserMonster $25 Amazon Gift Card
Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.

Register

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...