need some help with combining data vba
hi all!! I'm a little stuck on this one, and would appreciate any insight.
I currently have a macro that uses the data in the tab "Filtered from Current Year". It looks at column A, which lists the clients name, and then creates a tab for each client name, copying and pasting that line of data into each individual client tab. It then creates a chart with the data.
It works great, however, now i'm stuck with the improvement I want to do on it.
I added an additional tab of data - The new tab is named: "Filtered from Prev Year". This tab may have the same client names as the other. What i'm trying to do is look against both tabs, and create a tab for each client name, if the client name exists more than once, I'd like it to use both data lines in the client's tab.
How would you suggest that I do this?
Here is my code for creating tabs by client name:
I currently have a macro that uses the data in the tab "Filtered from Current Year". It looks at column A, which lists the clients name, and then creates a tab for each client name, copying and pasting that line of data into each individual client tab. It then creates a chart with the data.
It works great, however, now i'm stuck with the improvement I want to do on it.
I added an additional tab of data - The new tab is named: "Filtered from Prev Year". This tab may have the same client names as the other. What i'm trying to do is look against both tabs, and create a tab for each client name, if the client name exists more than once, I'd like it to use both data lines in the client's tab.
How would you suggest that I do this?
Here is my code for creating tabs by client name:
Sub Tab_Clients()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Filtered from Current Year")
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
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
'CHARTCLIENT
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Easiest / quickest way would be to copy exactly the same procedure and alter the name of the source worksheet as well as the target cell in the new sheets (use A2 rather than A1).
That might be good enough for now. A cleaner solution would take an hour or two to put in place I guess.
That might be good enough for now. A cleaner solution would take an hour or two to put in place I guess.
tried to copy the same procedure and alter the and and target cell. doesn't seem to be doing the trick. also takes forever!
Any help would be appreciated.
see sample data attached.
I call:
Tab_Clients1
Application.Wait (3)
Tab_Clients2
Any help would be appreciated.
see sample data attached.
Sub Tab_Clients2()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Filtered from Current Year")
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
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
CHARTCLIENT
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Sub Tab_Clients1()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Filtered from Prev Year")
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
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A5")
Sheets(myarr(i) & "").Columns.AutoFit
'CHARTCLIENT
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
I call:
Tab_Clients1
Application.Wait (3)
Tab_Clients2
I asked for a workbook sample you didn't reply. Fine, I created one.
Now for:
How you want the data to align ? Compare this year with last year or just throw the figures like they come ?
If to compare the figures then we need to know your labels and amounts and here again will need your sample workbook.
gowflow
Now for:
if the client name exists more than once, I'd like it to use both data lines in the client's tab.
How you want the data to align ? Compare this year with last year or just throw the figures like they come ?
If to compare the figures then we need to know your labels and amounts and here again will need your sample workbook.
gowflow
basically, i'd like Previous Year to show up starting on A1
Then Current Year data to show up a row below it. Let's say starting on A4.
ideally i'm looking to compare the flow by charting it..
Then Current Year data to show up a row below it. Let's say starting on A4.
ideally i'm looking to compare the flow by charting it..
ok fine take a look at this.
Try the attached file we can finetune it.
gowflow
SalesTY-LY.xlsm
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
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
vcol = 1
Set ws = Sheets("Filtered from Current Year")
Set WSPY = Sheets("Filtered from Prev Year")
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
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
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)
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
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
Try the attached file we can finetune it.
gowflow
SalesTY-LY.xlsm
thanks, i guess in combining the data now, i'd like to be able to distinguish it better.
I was thinking of adding a "column A", pushing the existing data over one.
If data exists in B2, then add in Column A2 "2014".
If data exists in B3, then add in Column A3 "2015".
Do you know how I can accomplish this?
Happy to open a new thread for points if need be.
I was thinking of adding a "column A", pushing the existing data over one.
If data exists in B2, then add in Column A2 "2014".
If data exists in B3, then add in Column A3 "2015".
Do you know how I can accomplish this?
Happy to open a new thread for points if need be.
awesome work gowflow. I created another thread for my last question for additional points:
http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28628598.html
http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28628598.html
Premium Content
You need an Expert Office subscription to comment.Start Free Trial