• 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...

  • 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

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.
 

Attachments

  • upload_2018-8-27_11-32-26.png
    upload_2018-8-27_11-32-26.png
    13.2 KB · Views: 3
  • upload_2018-8-27_11-33-2.png
    upload_2018-8-27_11-33-2.png
    14.9 KB · Views: 2
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
View attachment 54774


Current consolidated sheet
View attachment 54775

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.


Cross Post: https://stackoverflow.com/questions/52051822/map-all-columns-if-data-exist-after-particular-column[/CODE][/quote]
 
Last edited:
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:
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:
Hi p45cal,

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

Attachments

  • Console.xlsm
    20 KB · Views: 6
Last edited by a moderator:
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:
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]


Cross Post: https://www.excelforum.com/showthread.php?t=1243321&p=4964474#post4964474
 
While it is good to provide cross-posting reference, you should refrain from cross-posting (once you have response which you have from p45cal) generally. Since this is voluntary & unpaid work, you should be willing to wait.

Hi shrivallabha,

thanks for reply..your right, due urgency i have posted in other forums.. will keep this mind and wont repeat again.
 
try:
Code:
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:
try:
Code:
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!

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.
 

Attachments

  • Console1.xlsm
    42.2 KB · Views: 12
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:
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.
 
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.

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:
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:
    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
 

Attachments

  • Console2.xlsm
    43.1 KB · Views: 2
Last edited:
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:
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
 
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:
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


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.
 
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.
 
Back
Top