Update consolidate VBA

[Portucale]

Hi,

I currently use the code below to extract just the columns required from a workbook source, but I am encountering a small issue, as in the source we have a column name as "ADV_OffphoneHrs" and another column named as "ADV_Offphone", when the procedure run it picks up the data from the first column "ADV_OffphoneHrs" when in fact I need the data from the "ADV_Offphone". OK I know that a change in the headers would be a solution but as we have other reports and Databases running of the source I come this way to ask if there is any other solution.

Private Sub ADV_Hist()
Dim wsO As Worksheet
Dim wsF As Worksheet
Dim i As Integer
 
Application.ScreenUpdating = False
Worksheets.Add(after:=Worksheets("CEM")).Name = "ADV_Hist"
 
Set wsO = Worksheets("Advisor")
Set wsF = Worksheets("ADV_Hist")
myColumns = Array("ADV_Month ", "ADV_Payroll", "ADV_AgentID", "ADV_Name", _
"ADV_ComRate", "ADV_HCGroup", "ADV_NetRevenue", "ADV_HCScore", "ADV_AbsHours", _
"ADV_AbsencePerc", "ADV_HolidayDays", _
"ADV_HappyCustomer", "ADV_Value", "ADV_Holiday", "ADV_OffPhone", "ADV_Combined")
With wsO.Range("A1:AW1")
For i = 0 To UBound(myColumns)
On Error Resume Next
.Find(myColumns(i)).EntireColumn.Copy Destination:=wsF.Cells(1, i + 1)
Err.Clear
Next i
End With
Set wsO = Nothing
Set wsF = Nothing
    Sheets("ADV_Hist").Select
    With ActiveWorkbook.Sheets("ADV_Hist").Tab
        .Color = 255
        .TintAndShade = 0
    End With
    Range("A1").Select
Application.ScreenUpdating = True
End Sub

Many thanks for the help,

 

[sgmpatnaik]

@Portucale

Welcome to Changoo.org, Glad you are here, as per my understanding your First Column that is Column A named as ADV_OffphoneHrs and Column B as ADV_OffPhone if it is correct then correct this line as

for i = 0

change

for i = 2

it is better to upload a sample file to get better result

Thanks

 

[Portucale]

Thanks, but possibly I didn't explain correctly, sorry, I enclose a sample of the source and the required results, you will see in the source two columns in yellow and I need the data from the second, however currently the VBA code gives me the result of the first one...
Thanks for the help.

 

[SirJB7]

Hi, Portucale!

Give a look at the uploaded file. The problem was in the Range.Find method since it doesn't perform exact but approximated searches, so a workaround might be the code as follows. Hope you don't mind if I made a few slight tweaks:

Option Explicit
 
Private Sub ADV_Hist()
 
    ' constants
    Const ksSource = "Source" '"Advisor"
    Const ksConsolidate = "Consolidate" '"ADV_Hist"
   
    ' declarations
    Dim wsO As Worksheet
    Dim wsF As Worksheet
    Dim c As Range
    Dim i As Integer
    Dim myColumns As Variant
   
    ' start
    Application.ScreenUpdating = False
'    Worksheets.Add(after:=Worksheets("CEM")).Name = ksConsolidate
   
    ' process
    Set wsO = Worksheets(ksSource)
    Set wsF = Worksheets(ksConsolidate)
    myColumns = Array("ADV_Month ", "ADV_Payroll", "ADV_AgentID", "ADV_Name", _
        "ADV_ComRate", "ADV_HCGroup", "ADV_NetRevenue", "ADV_HCScore", "ADV_AbsHours", _
        "ADV_AbsencePerc", "ADV_HolidayDays", _
        "ADV_HappyCustomer", "ADV_Value", "ADV_Holiday", "ADV_OffPhone", "ADV_Combined")
    With wsO.Range("A1:AW1")
        For i = 0 To UBound(myColumns)
            Set c = .Find(myColumns(i))
            If Not c Is Nothing Then
                If c.Value = myColumns(i) Then c.EntireColumn.Copy Destination:=wsF.Cells(1, i + 1)
            End If
            Set c = Nothing
        Next i
    End With
   
    ' end
    With wsF.Tab
        .Color = 255
        .TintAndShade = 0
    End With
    Range("A1").Select
    Application.ScreenUpdating = True
    Set wsF = Nothing
    Set wsO = Nothing
   
End Sub

I commented the line where the new worksheet is created since it was already in the workbook, I trust that you could adjust it.

Just advise if any issue.

Regards!

 

[Portucale]

Hi,

Again many thanks for the help, but with the code kindly given by SirJB7 two things is happening... the column "ADV_Holidays" is not transposed and the information from "ADV_OffPhone" is also not originated from the correct column... any ideas?

Kind regards,

 

[SirJB7]

Hi, Portucale!
Those are not code errors but data errors:
Holyday: column AA name in worksheet Source "ADV_Holydays", value in array "ADV_Holiday" (missing trailer "s")
OffPHone: columns X & AG in worksheet Source (duplicated, Find method will take the 1st one only)
Regards!

 

[Portucale]

Hi SirJB7,
Apologies if you understood that I was criticizing the code, far away from me to do that. OK now I think I am starting to understand the issue so I can further explain. As you mention the Find method will take the first only, but in fact I have similar headers on the source like "ADV_HolidayDays / ADV_Holiday" as to "ADV_OffPhoneHrs / ADV_OffPhone", so the question is:

Is there a procedure that would transpose the information from each of these columns with the correct header?
or,
Is there any other solution like "give me the data from column AA and AG, as an example?

Thanks in advance,

 

[SirJB7]

Hi, Portucale!

No need to apologize for nothing, absolutely not, I didn't take that as a critic to my code (which it surely deserves more than one ). It's me who'd apologize for writing in such a rude mode while trying to be concise, if it was read as that my only excuse is to blame my non-native English, may I use it?

Back to the point, the Find methods searches the 1st occurence of the given argument, and that's why I replaced your original single line Find by a Find + and If to compare the whole retrieved value. So when you search for "ADV_Holidays"... stop! Now I see that you have ADV_Holydays in column S, ADV_HolydayDays in column AA and ADV_Holiday in column AF, so I'll change values in source to check if the code works fully as expected. Be back writing in a while.

Well, as I wrote earlier, my code surely deserved to be criticized. It worked but only it the searched argument was the first found into the multiple matching occurrences. Check the new uploaded file, and this is the fixed (I hope) code:

Option Explicit
 
Private Sub ADV_Hist()
 
    ' constants
    Const ksSource = "Source" '"Advisor"
    Const ksConsolidate = "Consolidate" '"ADV_Hist"
   
    ' declarations
    Dim wsO As Worksheet
    Dim wsF As Worksheet
    Dim c As Range
    Dim i As Integer
    Dim myColumns As Variant
   
    ' start
    Application.ScreenUpdating = False
'    Worksheets.Add(after:=Worksheets("CEM")).Name = ksConsolidate
   
    ' process
    Set wsO = Worksheets(ksSource)
    Set wsF = Worksheets(ksConsolidate)
    wsF.Cells.ClearContents
    myColumns = Array("ADV_Month ", "ADV_Payroll", "ADV_AgentID", "ADV_Name", _
        "ADV_ComRate", "ADV_HCGroup", "ADV_NetRevenue", "ADV_HCScore", "ADV_AbsHours", _
        "ADV_AbsencePerc", "ADV_HolidayDays", _
        "ADV_HappyCustomer", "ADV_Value", "ADV_Holiday", "ADV_OffPhone", "ADV_Combined")
    With wsO.Range("A1:AW1")
        For i = 0 To UBound(myColumns)
            Set c = .Find(myColumns(i))
            Do Until c Is Nothing
                If c.Value = myColumns(i) Then
                    c.EntireColumn.Copy Destination:=wsF.Cells(1, i + 1)
                    Exit Do
                End If
                Set c = .FindNext(c)
            Loop
            Set c = Nothing
        Next i
    End With
   
    ' end
    With wsF.Tab
        .Color = 255
        .TintAndShade = 0
    End With
    Range("A1").Select
    Application.ScreenUpdating = True
    Set wsF = Nothing
    Set wsO = Nothing
    Beep
   
End Sub

The original single Find, the following Find + If are now replaced by a structure of:
Find
Do until end
If = copy & exit
Find next
Loop

Hope it now works.

Regards!

 

[Smallman]

Hi

The following is my take on the problem. Bit late but international time lines often dictate and it is an interesting problem, my favs.

Portucale You are after an Exact match to solve your problem and XL provides a ready made solution with the Find method. That tick box with Match Entire Cell Contents is my puppy of choice. Also if you box up all of the items in your Array you can copy the Columns once only. This saves processing time if you have a large list in your array to iterate through. The code does not copy paste, copy paste etc, it just stores the location of the found column and moves on. At the end it does the lot in a batch process.

Anyways Here is the file and the code which is run from the Source Sheet.

Option Explicit
 
Sub MoveMeBaby()
Dim r As Range
Dim ar As Variant
Dim i As Integer
Dim fn As Range
Dim str As String
 
ar = Array("ADV_Month ", "ADV_Payroll", "ADV_AgentID", "ADV_Name", "ADV_ComRate", "ADV_HCGroup", "ADV_NetRevenue", "ADV_HCScore", "ADV_AbsHours", _
        "ADV_AbsencePerc", "ADV_HolidayDays", "ADV_HappyCustomer", "ADV_Value", "ADV_Holiday", "ADV_OffPhone", "ADV_Combined")
 
    For i = 0 To UBound(ar)
        Set fn = [A1:AW1].Find(ar(i), LookAt:=xlWhole)
        str = str & fn.Address & ","
    Next i
 
    str = Left(str, Len(str) - 1)
    Set r = Range(str).EntireColumn
    Worksheets.Add(after:=Worksheets("CEM")).Name = "ADV_Hist"
    r.Copy Sheets("ADV_Hist").[a1]
    ActiveSheet.Tab.Color = 255
End Sub

Oh I do not like that long list you have assigned in VB to the Variant. You would be better served creating a List Sheet and putting the headers in there and just updating that sheet rather than in the VB directly. The Code is very simple to Change and creates a cleaner look at the top of the code.

Take Care


Smallman

 

[SirJB7]

Hi, Portucale!

I knew but completely forgot about the LookAt parameter, so you'd better use this last posted approach for the Range.Find method usage. It'd require only a slight change in your original code, if you decide to keep it instead of adopting the whole solution.

Regards!

 

[Portucale]

Guys,

Many thanks for the help, I was so dumb, as I also had repeated column headers... with your help I have refined my reports and with no surprise it works perfectly, again I am forever in debt with you guys.

SirBJ7, we share the language issues as English isn't also my first language... As you may gather I am originally from Portugal, Lisbon , so I understand that sometimes what we want to explain is possibly in the most correct wording, never mind we got that in the end.

Cheers,

 

[SirJB7]

Hi, Portucale!
Glad you solved it. Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.
Regards!