VBA script - Multiple copies of each Row (problem).

**akarev** · 02-12-2013, 09:06 AM

Dear all,

My name is Alex and I am new to this forum. I have a very limited knowledge of Visual Basics, and I would be very glad if you could assist me with the following problem I have encountered.

I have an Excel database where I keep a record of all incoming calls to our organization (orders and general inquiries). In order to help me manage this database I decided to write a VBA script, which would split the entire database according to the name of the city the call was received from. There are only 4 (four) different cities in my database (these are the cities our business is operating in). Now, although my script works well (in a sense that it splits the entire database according to the city names), it has one major drawback - it creates multiple copies of each row whenever I run the script. Therefore, I was hoping that maybe someone from this community could help me to resolve this issue.

Here's my code:

 

Sub CopyPaste()

Dim ws As Worksheet
Dim LR As String
Dim LR2 As String
Dim myName As String
Set ws = Sheets("Call_centr")
LR = ws.Cells(Rows.Count, "B").End(xlUp).Row

For Each cl In Range("$B$2:$B" & LR)
    myName = cl
    LR2 = Sheets(myName).Cells(Rows.Count, "B").End(xlUp).Row + 1
    ws.Cells(cl.Row, "B").EntireRow.Copy Sheets(myName).Cells(LR2, "A")
Next cl
End Sub

And here's the link to the actual Excel file I am talking about.

Thank you very much in advance.

UPDATE: As far as I understand, one way of achieving the desired effect is to add one more line of code, which would add some sort of indication that this particular Row has already been Exported to the required Sheets. Hence, I could add additional Column in my database and name it "Indicator", which would store the information about the records which have already been exported. This is just a thought, if there's a better (less cluttered and efficient way) of achieving the desired effect, please let me know. Any help will be highly appreciated.

**AB33** · 02-12-2013, 10:12 AM

Try this one

Sub craetenames()
Dim i As Long, LR As Long, NR As Long, nome As String, sh As Worksheet, ws As Worksheet

    Application.ScreenUpdating = False
    On Error Resume Next
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .Name <> "Call_centr" Then
            .Cells.ClearContents
            End If
        End With
    Next ws
    
        With Sheets("Call_centr")
            LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For i = 2 To LR
                If Trim(.Range("B" & i).Value) <> "" Then
                    nome = Trim(.Range("B" & i).Value)
                    If Not Evaluate("ISREF('" & nome & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nome
                    End If
                    .Range("A1:AD1").Copy Worksheets(nome).Range("A1")
                    .Rows(i).Copy
                    Worksheets(nome).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next i
        Application.CutCopyMode = 0
       End With
       
            For Each sh In ThisWorkbook.Worksheets
                Application.DisplayAlerts = 0
                If InStr((sh.Name), "Sheet") > 0 Then sh.Delete
             sh.Columns("A:AD").EntireColumn.AutoFit
            Next
        
     Application.ScreenUpdating = True
     Application.DisplayAlerts = 1
End Sub

**akarev** · 02-12-2013, 10:28 AM

Originally Posted by AB33

Try this one

Sub craetenames()
Dim i As Long, LR As Long, NR As Long, nome As String, sh As Worksheet, ws As Worksheet

    Application.ScreenUpdating = False
    On Error Resume Next
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .Name <> "Call_centr" Then
            .Cells.ClearContents
            End If
        End With
    Next ws
    
        With Sheets("Call_centr")
            LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For i = 2 To LR
                If Trim(.Range("B" & i).Value) <> "" Then
                    nome = Trim(.Range("B" & i).Value)
                    If Not Evaluate("ISREF('" & nome & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nome
                    End If
                    .Range("A1:AD1").Copy Worksheets(nome).Range("A1")
                    .Rows(i).Copy
                    Worksheets(nome).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next i
        Application.CutCopyMode = 0
       End With
       
            For Each sh In ThisWorkbook.Worksheets
                Application.DisplayAlerts = 0
                If InStr((sh.Name), "Sheet") > 0 Then sh.Delete
             sh.Columns("A:AD").EntireColumn.AutoFit
            Next
        
     Application.ScreenUpdating = True
     Application.DisplayAlerts = 1
End Sub

Hi AB33,

Thank you very much for your help! It works like a charm! I can't believe that you did all this in such a short period of time (it would definitely take me at least a year to figure it out myself). I thought that the code will be much simpler, but it looks so complicated, but works perfect!

Once again, thank you very much for your help, you really really helped me!

Sincerely,

Alex

**AB33** · 02-12-2013, 10:35 AM

Alex,
Glad to be helpful and you are welcome!
Next time, please do not reply with Quote, it does not have any purpose but to clutter this space. Just click "Reply"
Could you please now close this thread as solved. Go in to the top right-hand side of this page, choose "Thread Tools", select solved from the drop down menu.

**akarev** · 02-12-2013, 10:39 AM

Done. I have also added you some sort of "reputation". Not exactly sure what this is, but hey, why not

Thanks.

**AB33** · 02-12-2013, 10:46 AM

Alex,

Thanks again for "Rep"

VBA script - Multiple copies of each Row (problem).

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

VBA script - Multiple copies of each Row (problem).

Re: VBA script - Multiple copies of each Row (problem).

Re: VBA script - Multiple copies of each Row (problem).

Re: VBA script - Multiple copies of each Row (problem).

Re: VBA script - Multiple copies of each Row (problem).

Re: VBA script - Multiple copies of each Row (problem).

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions