Announcement

Collapse
No announcement yet.

Copy/paste the entire row before splitting cell values

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Copy/paste the entire row before splitting cell values



    Hello,
    i have this code and I would like to insert a line to copy/paste the line before splitting the cell values whether there is a comma or not.
    thank you for your help!
    Best,

    Code:
    Option Explicit
    Sub ReorgData()
    ' Stanley D. Grom, 01/17/2012
    ' http://www.ozgrid.com/forum/showthread.php?t=161519
    Dim w1 As Worksheet, wR As Worksheet
    Dim lr As Long, r As Long, Sp, n As Long
    Application.ScreenUpdating = False
    Set w1 = Worksheets("Sheet1")
    If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
    Set wR = Worksheets("Results")
    wR.UsedRange.Clear
    w1.UsedRange.Copy wR.Range("A1")
    lr = wR.Cells(Rows.Count, 3).End(xlUp).Row
    For r = lr To 1 Step -1
    If InStr(wR.Cells(r, 3), ",") > 0 Then
    Sp = Split(wR.Cells(r, 3), ",")
    wR.Rows(r + 1).Resize(UBound(Sp)).Insert
    wR.Cells(r, 3).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
    wR.Cells(r, 1).Resize(UBound(Sp) + 1) = wR.Cells(r, 1)
    End If
    Next r
    wR.UsedRange.Columns.AutoFit
    wR.Activate
    Application.ScreenUpdating = True
    End Sub

  • #2
    Code Tags Added
    Your post does not comply with our Forum RULES. Use code tags around code.

    Posting code between tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

    Highlight your code and click the # icon at the top of your post window.

    (I have added them for you today. Please take a few minutes to read all Forum Rules and comply in the future.)
    Alan

    Did you debug your code first? http://www.cpearson.com/excel/DebuggingVBA.aspx
    FORUM RULES----->http://www.ozgrid.com/forum/announcement.php?f=8

    If someone has helped you, say "thank you" by clicking on the Like Button.

    Comment


    • #3
      Perhab like this
      Code:
      Option Explicit
      Sub ReorgData()
       Dim w1 As Worksheet, wR As Worksheet
       Dim lr As Long, r As Long, Sp, n As Long,i as long
       Application.ScreenUpdating = False
      Set w1 = Worksheets("Sheet1")
       If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
      
       Set wR = Worksheets("Results")
      
       wR.UsedRange.ClearContents
      
       w1.UsedRange.Copy wR.Range("A1")
      
       '------change [email protected]
      dim x,a(),ii&
      With wR.usedRange
         x = .Value :redim a(1 to ubound(x) * 100 ,1 to 2)
         for n = 1 to ubound(x)
             If Instr(x(n,3),",") then
              sp = split(x(n,3),",")  
               for ii = 0 to ubound(sp)  
                   i = i + 1  
                  a(i,2) = sp(ii)  
                  a(i,1) = x(n,1)  
               next ii  
            end if  
         next n  
         .ClearContents
         .range("a1").resize(i,ubound(a,2)) = a
         .Columns.Autofit  
          .Activate
      End with
      Application.ScreenUpdating = True
      End Sub

      Comment


      • #4
        Or if there ara comma or not
        Code:
         Option Explicit
        
        Sub ReorgData()  
        Dim w1 As Worksheet, wR As Worksheet
         Dim lr As Long, r As Long, Sp, n As Long,i as long
         Application.ScreenUpdating = False
        
        Set w1 = Worksheets("Sheet1")  
        If Not Evaluate("ISREF(Results!A1)") Then
               Worksheets.Add(After:=w1).Name = "Results"  
        end if
           Set wR = Worksheets("Results")  
           wR.UsedRange.ClearContents
           w1.UsedRange.Copy wR.Range("A1")  
        
        '------change [email protected]
        dim x,a(),ii&,s$
        With wR.usedRange  
         x = .Value :redim a(1 to ubound(x) * 100 ,1 to 2)
             for n = 1 to ubound(x)
               If Instr(x(n,3),",") then s = "," else s = " "
                   sp = split(x(n,3),s)
                   for ii = 0 to ubound(sp)
                       i = i + 1  
                       a(i,2) = sp(ii)    
                       a(i,1) = x(n,1)    
                   next ii    
             next n  
           .ClearContents    
           .range("a1").resize(i,ubound(a,2)) = a    
           .Columns.Autofit  
           .Activate
        End with
        Application.ScreenUpdating = True
        End Sub

        Comment


        • #5
          thank you very much for your answer. but hereunder is what I have. the first code is working fine but I want to keep the original line and after break it down (that's why I want to copy paste before splitting.
          Attached Files

          Comment


          • #6
            Please give picture i am.not use pc but using handphone

            Comment


            • #7
              Click image for larger version

Name:	Capture.PNG
Views:	2
Size:	81.3 KB
ID:	1210722

              Comment


              • #8
                Mybi try this ,OK thank For FeedBack dont Forget Mark case as Solved
                Code:
                Option Explicit
                Sub Graha_Rev()
                'rev by Graha _ Karya
                Dim w1 As Worksheet, wR As Worksheet
                Dim lr As Long, r As Long, Sp, n As Long, t1$: Application.ScreenUpdating = False
                Set w1 = Worksheets("Sheet1")
                '''''''' IF NOT EXISTS SHEET ADD SHEET
                If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
                  Set wR = Worksheets("Results")
                  wR.UsedRange.Clear
                  w1.UsedRange.Copy wR.Range("A1")
                  lr = wR.Cells(Rows.Count, 3).End(xlUp).Row
                  '''''''' LR TO 2 except Header (Header to executed)
                For r = lr To 2 Step -1
                    '''''''' if instr or exists ","
                    If InStr(wR.Cells(r, 3), ",") > 0 Then
                          n = 0: n = IIf(n = 0, r + 1, n)    'set n ,for consta  number  dont forget to reset if not true in above 
                          t1 = wR.Cells(r, 3)
                          Sp = Split(t1, ",")
                          wR.Rows(n).Resize(UBound(Sp) + 1).Insert
                          wR.Cells(r, 3) = t1    'add this because has delete by transpose
                          wR.Cells(n, 3).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)  'n = r+1
                          wR.Cells(n, 4).Resize(UBound(Sp) + 1) = wR.Cells(r, 4)
                          wR.Cells(n, 5).Resize(UBound(Sp) + 1) = wR.Cells(r, 5)
                          wR.Cells(n, 1).Resize(UBound(Sp) + 1) = wR.Cells(r, 1)
                          
                    ElseIf Not wR.Cells(r, 3) = Empty And Not InStr(wR.Cells(r, 3), ",") Then
                         '''''' else not instr comma and not empty
                         n = 0: n = IIf(n = 0, r + 1, n)
                         wR.Rows(n).Resize(1).Insert
                         wR.Cells(n, 3).Resize(1) = wR.Cells(r, 3)
                         wR.Cells(n, 4).Resize(1) = wR.Cells(r, 4)
                         wR.Cells(n, 5).Resize(1) = wR.Cells(r, 5)
                         wR.Cells(n, 1).Resize(1) = wR.Cells(r, 1)
                    End If
                Next r
                wR.UsedRange.Columns.AutoFit: wR.Activate: Sp = ""
                Application.ScreenUpdating = True
                End Sub

                Comment


                • #9
                  OR YOU CAN DO USING SWAPING ARRAY ,IS MORE EASY TO DO
                  Code:
                  Option Explicit
                  Sub Swap_Array()
                  Dim Sp, i&, x, a(), rw&, j&, n&, wS As Worksheet
                  Set wS = Worksheets("Sheet1")
                  With wS.UsedRange
                     x = .Value: ReDim a(1 To UBound(x) * 100, 1 To UBound(x, 2))
                  End With
                       For n = 1 To UBound(x)
                         If Not x(n, 3) = "country" Then
                              If InStr(x(n, 3), ",") Then
                                rw = rw + 1
                                Sp = Split(x(n, 3), ",")
                                     a(rw, 1) = x(n, 1): a(rw, 2) = x(n, 2): a(rw, 3) = x(n, 3)
                                     a(rw, 4) = x(n, 4): a(rw, 5) = x(n, 5)
                                          For j = 0 To UBound(Sp)
                                               rw = rw + 1
                                               a(rw, 1) = x(n, 1): a(rw, 2) = "": a(rw, 3) = Sp(j): a(rw, 4) = x(n, 4)
                                               a(rw, 5) = x(n, 5)
                                          Next j
                               ElseIf Not InStr(x(n, 3), ",") And Not IsEmpty(x(n, 1)) Then
                                              
                                           For j = 1 To 2
                                                rw = rw + 1
                                                a(rw, 1) = x(n, 1): a(rw, 2) = IIf(j = 1, x(n, 2), ""): a(rw, 3) = x(n, 3)
                                                a(rw, 4) = x(n, 4): a(rw, 5) = x(n, 5)
                                           Next j
                               End If
                           End If
                       Next n
                   
                    If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Results"
                    With Sheets("Results")
                      .UsedRange.ClearContents
                      .[a1].Resize(, 5) = Array("Code", "country", "Comments", "Start date", "End date")
                      .[a2].Resize(UBound(a, 1), UBound(a, 2)) = a: .UsedRange.Columns.AutoFit: .Activate: Erase a
                    End With
                  Application.ScreenUpdating = True
                  End Sub
                  Attached Files

                  Comment


                  • #10


                    thank you very much. that solve my problem. thanks

                    Comment

                    Working...
                    X