1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Map All columns if data exist after particular column

Discussion in 'VBA Macros' started by devendra.dvm, Aug 27, 2018.

  1. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi Experts,

    I am working on consolidation of all sheets and map previously consolidated status,

    I have one code which is working perfectly till consolidation, now i need a code to vlookup a status from previous consolidated sheet to current consolidated sheet.

    This is previous consolidated sheet
    upload_2018-8-27_11-33-33.png


    Current consolidated sheet
    upload_2018-8-27_11-36-7.png

    i want to map if data is there after column C in previous sheet with headings to current sheet starting from D column.


    Any help greatly appreciated.

    thanks in advance.

    Attached Files:

  2. devendra.dvm

    devendra.dvm Member

    Messages:
    171

    Cross Post: https://stackoverflow.com/questions/52051822/map-all-columns-if-data-exist-after-particular-column[/CODE][/quote]
    Last edited: Aug 28, 2018
  3. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    I am able to map column D with my code but i need to map rest of the non-blank columns also.

    This is my code so far.
    Code (vb):


    Sub FMEA_Consolidate()
    Application.ScreenUpdating =FalseDim SheetName AsString
    SheetName = Format(Date,"dd-mmm-yy")

    ''''''''''''''''''''''''''''''''''''''''Rename Last consolidated as Old if exist'''''''''''''''''''''''''''''''''''

    Dim ws As WorksheetForEach ws In SheetsIf InStr(1, ws.Name,"latest", vbTextCompare)<>0Then
    Sheets("Consolidated").Activate
    Range("D1")= ws.Name
    Range("D1").Interior.Color =65535
    ws.Name ="old"EndIfNext

    ''''''''''''''''''''''''''''''''''''''''If Last Old exist then Map previous status'''''''''''''''''''''''''''''
    Dim Lastws As Worksheet
    ForEach Lastws In SheetsIf InStr(1, Lastws.Name,"old", vbTextCompare)<>0Then
    Sheets("Consolidated").Activate
    Range("D2").Select

    Selection.FormulaArray = _
    "=IFERROR(INDEX(Old!C[-1],MATCH((RC[-2]&RC[-3]),(Old!C[-2]&Old!C[-3]),0),0),0)"

    Range("D2").AutoFill Destination:=Range("D2:D"& Range("A"& Rows.Count).End(xlUp).Row)

    ActiveSheet.Range("D2:D"& Range("D2:D"& Rows.Count).End(xlDown).Row).Copy
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Application.CutCopyMode =False
    Sheets("old").Delete
    EndIfNext

    ActiveSheet.Name ="Latest Consolidated "& SheetName
    Range("D2").SelectEndSub

    [CODE]
    Last edited: Aug 28, 2018
  4. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    Supply a workbook with some data in it so that we don't have to make one up to test our (and your) solutions.
    devendra.dvm likes this.
  5. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    Thanks for your response, have attached my working file for your reference.

    Attached Files:

    Last edited by a moderator: Aug 28, 2018
  6. devendra.dvm

    devendra.dvm Member

    Messages:
    171

    Cross Post: https://www.excelforum.com/showthread.php?t=1243321&p=4964474#post4964474
  7. shrivallabha

    shrivallabha Excel Ninja

    Messages:
    1,918
    devendra.dvm likes this.
  8. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi shrivallabha,

    thanks for reply..your right, due urgency i have posted in other forums.. will keep this mind and wont repeat again.
  9. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    try:
    Code (vb):
    Sub FMEA_Consolidate()
    Dim SourceSht As Worksheet, DestnSht As Worksheet, rngSourceColumnHeaders As Range, lr As Long, rngDestnHeaders As Range, rngDestnDataBody As Range
    Application.ScreenUpdating = False
    Set DestnSht = Sheets("Consolidated")
    For Each SourceSht In Sheets
      If InStr(1, SourceSht.Name, "latest", vbTextCompare) > 0 Then Exit For
    Next
    'at this point, SourceSht is the first sheet encountered which has 'latest' somewhere in its name  .
    'Column extent of source data:
    With SourceSht
      Set rngSourceColumnHeaders = .Range(.Cells(1, "C"), .Cells(1, .Columns.Count).End(xlToLeft))
    End With
    'extent of destination sheet:
    With DestnSht
      lr = .Cells(.Rows.Count, "A").End(xlUp).Row
      Set rngDestnHeaders = .Cells(1, "D").Resize(, rngSourceColumnHeaders.Columns.Count)
      Set rngDestnDataBody = rngDestnHeaders.Offset(1).Resize(lr - 1)
      rngSourceColumnHeaders.Copy rngDestnHeaders.Cells(1)
      With rngDestnDataBody
        .Cells(1).FormulaArray = "=IFERROR(INDEX('" & SourceSht.Name & "'!R1C[-1]:R" & lr & "C[-1],MATCH((RC2&RC1),('" & SourceSht.Name & "'!R1C2:R" & lr & "C2&'" & SourceSht.Name & "'!R1C1:R" & lr & "C1),0),0),0)"
        .Cells(1).AutoFill Destination:=.Columns(1), Type:=xlFillDefault
        .Columns(1).AutoFill Destination:=.Cells, Type:=xlFillDefault
        .Value = .Value    'temporarily comment-out this line to satisfy yourself the formulae are correct.
     End With
      rngDestnHeaders.Cells(1) = SourceSht.Name
      rngDestnHeaders.Cells(1).Interior.Color = 65535
      rngDestnHeaders.Cells(1).Font.ColorIndex = xlAutomatic
      SourceSht.Delete
      .Name = "Latest Consolidated " & Format(Date, "dd-mmm-yy")
    End With
    Application.ScreenUpdating = True
    End Sub
    There's a comment in the code:
    temporarily comment-out this line to satisfy yourself the formulae are correct
    If you do this you will also have to put a break in the code before SourceSht.Delete so that the sheet that those formulae refer to still exists!
    Last edited: Aug 28, 2018
  10. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    Thanks for the code, your code is working like champ... thanks a lot for the same...
  11. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    your code is working perfectly but later i came to know that index formal is not mapping correctly.
    iam using this in my actual file.. have attached my actual file for your reference... pls help on the same..


    thanks in advance.

    Attached Files:

  12. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    In your first sample file your columns A & B together made a row unique.
    In your latest attached file this doesn't apply.
    The formula you supplied in msg#3 also implied that the rows would be unique on any given sheet.
    The INDEX/MATCH formula will only ever find the first (highest one on the sheet).

    This whole method of creating a new consolidated file from the most recent also implies that you only want to see a history for rows on the latest sheet?

    Anyway, the first two columns aren't enough to identify uniquely each row, nor are the first 3 columns. The first 4 columns are enough with your sample data, but aren't guaranteed to be so always.
    Are the rows always in the exact same order, day to day? I doubt it somehow.
    How would you manually tie up an old row with the new one?
    Last edited: Sep 1, 2018
    devendra.dvm likes this.
  13. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    Thanks for the reply...i was out station without internet access thats why i didn't responded to your reply immediately...

    in my latest sample column-A and column-D together are unique.. and these are always match with destination sheet column-A and column-D.. with these unique columns i want map all the columns from or after column-F from source sheet.
  14. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    No they're not! Using those criteria rows 6 and 7 are duplicates, so are 9 & 10, 13 & 14 and 107 through 110. It won't work.
    devendra.dvm likes this.
  15. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    your right, is there any way that we can consider columns A,B,C,D all together as unique ?
  16. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    Please help me with the code by considering Columns A,B,C,D in my latest sample...


    thanks in advance
  17. devendra.dvm

    devendra.dvm Member

    Messages:
    171
    Hi p45cal,

    with below code im able to map column-F but after "F" im unable to map for dynamic range...
    getting error ''' Method 'Range' of object '_Worksheet' failed''' on this lines
    Code (vb):

    DestnSht.Range("MyHeaders" & j).Value = SourceSht.Range("rngSourceColumnHeaders" & i).Value
                           
         Else
                           
    DestnSht.Range("MyHeaders" & j).Value = "0"
     
    have attached my working for your reference.
    please help me with correction.

    thanks in advance.

    Code (vb):


        Sub FMEA_Consolidate()
         
             Dim rngSourceColumnHeaders As Range, lr As Long, rngDestnHeaders As Range, rngDestnDataBody As Range, DestnSht As Worksheet, SourceSht As Worksheet
        Dim MyHeaders As Range
     
       
        Application.ScreenUpdating = True
     
     
        Set DestnSht = Worksheets("Consolidated")
     
        For Each SourceSht In Sheets
          If InStr(1, SourceSht.Name, "latest", vbTextCompare) <> 0 Then
     
     
        With SourceSht
     
        Set rngSourceColumnHeaders = .Range(.Cells(1, "F"), .Cells(1, .Columns.Count).End(xlToLeft))
     
          'Set rngSourceColumnHeaders = .Range(.Cells(1, "F"), .Cells(1, .Columns.Count).End(xlToLeft))
       End With
     
     
        With DestnSht
          'lr = .Cells(.Rows.Count, "A").End(xlUp).Row
         Set rngDestnHeaders = .Cells(1, "G").Resize(, rngSourceColumnHeaders.Columns.Count)
         ' Set rngDestnDataBody = rngDestnHeaders.Offset(1).Resize(lr - 1)
         rngSourceColumnHeaders.Copy rngDestnHeaders.Cells(1)
       
          Set MyHeaders = .Range(.Cells(1, "G"), .Cells(1, .Columns.Count).End(xlToLeft))
          End With
     
        'End If

            End If
     
         
            Dim i As Long
            Dim j As Long
            'Dim ws As Worksheet
           'Dim ws2 As Worksheet

            'Set ws = Sheet1
           'Set ws2 = Sheet2
           j = 1
            For i = 1 To 500000
                If IsEmpty(SourceSht.Range("A" & i)) Then
                    Exit For
                End If
                    If IsEmpty(DestnSht.Range("A" & j)) Then
                        Exit For
                    End If
     
                    If SourceSht.Range("D" & i).Value = DestnSht.Range("D" & j).Value And SourceSht.Range("C" & i).Value = DestnSht.Range("C" & j).Value And SourceSht.Range("B" & i).Value = DestnSht.Range("B" & j).Value And SourceSht.Range("A" & i).Value = DestnSht.Range("A" & j).Value Then
             
                         
                            DestnSht.Range("MyHeaders" & j).Value = SourceSht.Range("rngSourceColumnHeaders" & i).Value
                         
                        Else
                         
                                DestnSht.Range("MyHeaders" & j).Value = "0"
                         

        ''''''''''''''''''''''''''if put this lie maping column-G ''''''''''''''''''''''''''''''''''''''
                                             
                'DestnSht.Range("G" & j).Value = SourceSht.Range("G" & i).Value
                         
                        'Else
                         
                 'DestnSht.Range("G" & j).Value = "0"
       ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''





                        End If
                  j = j + 1
            Next i
         
     
         
            'MsgBox ("Finished ")
           Next
         
         
        End Sub
     

     

    Attached Files:

    Last edited: Sep 4, 2018
  18. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    Major difficulty trying to get long array formula into a cell using code - exceeded 255 character limit doing it this way because of your long sheet names.
    Plan B was to do it entirely in code.
    I note that you moved the Next SourceSht line down near the bottom of the macro, as if to process multiple sheets with Latest in their names. It wasn't designed to work that way (it will overwrite data produced by previous sheets with Latest in their names). I haven't time to work out what you want to happen so here's the solution for when there's only one sheet with Latest in its name.
    Code (vb):
    Sub Macro4()
    Dim colm As Long
    Dim SourceSht As Worksheet, DestnSht As Worksheet, rngSourceColumnHeaders As Range, lr As Long, rngDestnHeaders As Range, rngDestnDataBody As Range
    Application.ScreenUpdating = False
    Set DestnSht = Sheets("Consolidated")
    For Each SourceSht In Sheets
      If InStr(1, SourceSht.Name, "latest", vbTextCompare) <> 0 Then
        'at this point, SourceSht is the first sheet encountered which has 'latest' somewhere in its name  .
       With SourceSht
          SceLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
          Set rngSourceColumnHeaders = .Range(.Cells(1, "F"), .Cells(1, SceLC))
          SceVals = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, SceLC)).Value
        End With
        With DestnSht
          DestLR = .Cells(.Rows.Count, "A").End(xlUp).Row
          Set rngDestnHeaders = .Cells(1, "G").Resize(, rngSourceColumnHeaders.Columns.Count)
          Set rngDestnDataBody = rngDestnHeaders.Offset(1).Resize(DestLR - 1)
          ReDim myresults(1 To rngDestnDataBody.Rows.Count, 1 To rngDestnDataBody.Columns.Count)
          rngSourceColumnHeaders.Copy rngDestnHeaders.Cells(1)
          DestnFirst4ColumnsVals = .Range(.Cells(2, 1), .Cells(DestLR, 4)).Value
          For DestnRow = 1 To rngDestnDataBody.Rows.Count
            For SceRow = 1 To UBound(SceVals)
              AllSame = True
              For colm = 1 To 4 'this is where it compares each sheet's columns A to D.
               If DestnFirst4ColumnsVals(DestnRow, colm) <> SceVals(SceRow, colm) Then
                  AllSame = False
                  Exit For
                End If
              Next colm
              If AllSame Then
                For i = 1 To UBound(myresults, 2)
                  myresults(DestnRow, i) = SceVals(SceRow, i + 5)
                Next i
              End If
            Next SceRow
          Next DestnRow
       
          rngDestnDataBody.Value = myresults
          rngDestnHeaders.Cells(1) = SourceSht.Name
          rngDestnHeaders.Cells(1).Interior.Color = 65535
          rngDestnHeaders.Cells(1).Font.ColorIndex = xlAutomatic
          Application.DisplayAlerts = False
          SourceSht.Delete
          Application.DisplayAlerts = True
        End With
      End If
    Next
    With DestnSht
      .Name = "Latest Consolidated " & Format(Date, "dd-mmm-yy")
      If .Range("H1").Value <> 0 Then
        Range(.Columns("G:G"), .Columns("G:G").End(xlToRight)).ColumnWidth = 15
      Else
        Columns("G:G").ColumnWidth = 15
      End If
    End With
    Application.ScreenUpdating = True
    End Sub
  19. devendra.dvm

    devendra.dvm Member

    Messages:
    171

    Hi p45cal

    Thanks for the code.. will check the same...i missed one point to mentioned in my earlier post.. ie.. i want to sort the data in descending order based on column-E.. i have tried for the same bate other columns not changing accordingly as per the the column-E..

    Any help greatly appreciated. thank you.
  20. p45cal

    p45cal Well-Known Member

    Messages:
    1,243
    Let's get you to do some work; record a macro of you doing the sorting on the sheet. Post what you get here. Then I'll tweak it.
    devendra.dvm likes this.

Share This Page