• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 100
  • Last Modified:

swap lines of data within vba macro

Hello all,

I have a code which create tabs based on 2 workbooks of data. Each workbook is a different year. i.e . 2014 and 2015. Right now the data uses 2014 as a basis, and if any new clients were added in 2015, they get missed in the code.

I want to make sure all clients from 2014 and 2015 have a tab. I just want to swap the way the data is displayed on each tab showing 2014 first, b/c i then chart the data, and it's weird when it shows 2015 then 2014 in a bar graph.

please help.

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSPY As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String
Dim ThisYr As String, LastYr As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Prev Year")
LastYr = Format(Year(Now) - 1, "@")

Set WSPY = Sheets("Filtered from Current Year")
ThisYr = Format(Year(Now), "@")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    
    
'    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
'        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
'    Else
'        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
'    End If
    
    
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    
    
    
    If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
        Sheets(myarr(i) & "").Range("A1") = "Year"
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    Else
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    End If
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSPY.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                Sheets(myarr(i) & "").Range("A" & MaxRow).Insert xlShiftToRight
                Sheets(myarr(i) & "").Range("A" & MaxRow) = ThisYr
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

CHARTCLIENT2

Next
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window

0
jfrank85
Asked:
jfrank85
1 Solution
 
gowflowCommented:
ok I have created after the routine finishes pulling last year and this year customers a new routine that will pull all of this year that were not in last year and create a tab for them.

Here is the new code for that and in the attached workbook.

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSThis As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String
Dim ThisYr As String, LastYr As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Prev Year")
LastYr = Format(Year(Now) - 1, "@")

Set WSThis = Sheets("Filtered from Current Year")
ThisYr = Format(Year(Now), "@")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
        Sheets(myarr(i) & "").Range("A1") = "Year"
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    Else
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    End If
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSThis.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                Sheets(myarr(i) & "").Range("A" & MaxRow).Insert xlShiftToRight
                Sheets(myarr(i) & "").Range("A" & MaxRow) = ThisYr
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

    'CHARTCLIENT
Next

'---> Loop thru all clients and add tab for those not existing
lr = WSThis.Cells(WSThis.Rows.Count, vcol).End(xlUp).Row
For i = 2 To lr
    On Error Resume Next
    If WSThis.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(WSThis.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        WSThis.Cells(WSThis.Rows.Count, icol).End(xlUp).Offset(1) = WSThis.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(WSThis.Columns(icol).SpecialCells(xlCellTypeConstants))
WSThis.Columns(icol).Clear

For i = 2 To UBound(myarr)
    WSThis.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    
        '---> Get Data only for the sheets that have This year and not last year
        If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
            WSThis.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
            Sheets(myarr(i) & "").Range("A1") = "Year"
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
        Else
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
        End If
    End If

    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

Next i

WSThis.AutoFilterMode = False
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window


Pls check if it is correct and all info is there.
Rgds/gowflow
Sales-TY-LY-V04.xlsm
0
 
jfrank85Author Commented:
yes that worked thanks. having some issues now where it doesn't including some client names, and i wonder if it's because of the # of characters?

I created a new post:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28630833.html

thanks again!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

Tackle projects and never again get stuck behind a technical roadblock.
Join Now