copy cell value from sheet to sheet with conditions

[soso123]

Hi,I have two sheets and i need help with macro (VBA Code ) that can do the following:

-copy cell value from the "exp sheet" to the "bud sheet" as follow:

-if the code column in "exp sheet" for example (AX.0308) is found in "bud sheet" then copy each cell value in that column to the approiat "exp cells" and delete the column with shift to left.

-if the code clolumn in "exp sheet" for example (FX.0070) not found in "bud sheet" then copy the column and insert it at the right end before "Grand Total" column .

kindly check the attached file for more help.....

Thanks in advance for your time and try .....

[rylo]

Hi

You have 2 code Off-002 items. Is this correct? Are you likely to have more items with >1 instances?

The code below should action all those items that have 1 match for the code.

Sub aaa()
  Dim BudSH As Worksheet, ExpSH As Worksheet
  Set BudSH = Sheets("bud")
  Set ExpSH = Sheets("exp")
  ExpSH.Activate
  lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  For Each ce In Range("C1", Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1))
    Set findit = BudSH.Range("1:1").Find(what:=ce.Value)
    If findit Is Nothing Then
        BudSH.Cells(1, Columns.Count).End(xlToLeft).EntireColumn.Insert
        BudSH.Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1).Value = ce.Value
        Set findit = BudSH.Range("1:1").Find(what:=ce.Value)
    End If
    For i = 2 To lastrow
        Set findcode = BudSH.Range("A:A").Find(what:=Cells(i, 1).Value)
        cntr = WorksheetFunction.CountIf(BudSH.Range("A:A"), Cells(i, 1).Value)
        
        If Not findcode Is Nothing And cntr = 1 Then
            BudSH.Cells(findcode.Row + 1, findit.Column).Value = Cells(i, ce.Column).Value
        End If
    
    
    Next i
  
  Next ce
  
End Sub

rylo

[Leith Ross]

Hello soso123,

Welcome to the Forum!

Here is another version of the macro. If you have a lot of data to copy then you may want to use this version which is faster. While Rylo's code is shorter, it runs 5 times slower on my machine on the given data sample. I have added a button on the "exp" sheet to run the macro.

'Thread: http://www.excelforum.com/excel-programming/780898-copy-cell-value-from-sheet-to-sheet-with-conditions.html
'Poster: soso123
'Written: June 20, 2011
'Author:  Leith Ross

Option Explicit

Sub Macro1()

  Dim budHeaders As Range
  Dim budRng As Range
  Dim budWks As Worksheet
  Dim C As Long
  Dim Cell As Range
  Dim Dict As Object
  Dim expHeaders As Range
  Dim expRng As Range
  Dim expWks As Worksheet
  Dim Key As Variant
  Dim R As Long
 
    Set expWks = Worksheets("exp")
    Set budWks = Worksheets("bud")
    
    Set expRng = expWks.Cells(1, 1).CurrentRegion
    Set expHeaders = expRng.Offset(0, 2).Resize(1, expRng.Columns.Count - 2)
     
    Set budRng = budWks.Cells(1, 1).CurrentRegion
    Set budHeaders = budRng.Offset(0, 2).Resize(1, budRng.Columns.Count - 2)
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
     'Save the "bud" headers in the lookup array
      For Each Cell In budHeaders
        Key = Trim(Cell)
        If Key <> "" Then
          If Not Dict.Exists(Key) Then
             Dict.Add Key, 1
          End If
        End If
      Next Cell
      
     'Check for any "exp" headers that are missing in the "bud" headers
      For Each Cell In expHeaders
        Key = Trim(Cell)
        If Key <> "" Then
         'Add a new column for the missing header
          If Not Dict.Exists(Key) Then
             C = budRng.Columns.Count
             budRng.Columns(C).EntireColumn.Insert
             budWks.Cells(1, C) = Key
          End If
        End If
      Next Cell
      
     'Clear the lookup array
      Dict.RemoveAll
    
     'Save the "exp" data and codes in the lookup array
      For R = 2 To expRng.Columns(1).Cells.Count
        For C = 3 To expRng.Columns.Count
          Key = Trim(expRng.Cells(R, 1) & expRng.Cells(1, C))
          If Key <> "" Then
            If Not Dict.Exists(Key) Then
               Dict.Add Key, expRng.Cells(R, C)
            End If
          End If
        Next C
      Next R
           
     'Fill in the "bud" sheet
      For R = 3 To budRng.Columns(2).Cells.Count Step 3
        For C = 3 To budRng.Columns.Count
          Key = Trim(budRng.Cells(R - 1, 1) & budRng.Cells(1, C))
          If Key <> "" Then
            If Dict.Exists(Key) Then
               budRng.Cells(R, C) = Dict(Key).Value
            End If
          End If
        Next C
      Next R
            
End Sub

[soso123]

Big Thanks for both of you ....

But i use Leith Code ... Thanks againe ....

i have a question for checking the difference between the bud and exp :
i need to but the resulte of (bud - exp) in deff cells with changing the cells color
so i need macro to scan for all deff cell and do the formla into all founded deff cells
and the last row and column in the table will have a grand total .
Kindly check the attached file (AfterMacro Sheet)

Thanks for your time and help....

[Leith Ross]

Hello sos0123,

Here is the updated macro. This will automatically add the SUM formulas to the last column on the "bud" sheet.

'Thread: http://www.excelforum.com/excel-programming/780898-copy-cell-value-from-sheet-to-sheet-with-conditions.html
'Poster: soso123
'Written: June 20, 2011
'Updated: June 25, 2011 - Added SUM formulas to the last column.
'Author:  Leith Ross

Option Explicit

Sub Macro1()

  Dim budHeaders As Range
  Dim budRng As Range
  Dim budWks As Worksheet
  Dim C As Long
  Dim Cell As Range
  Dim Dict As Object
  Dim EndCell As String
  Dim expHeaders As Range
  Dim expRng As Range
  Dim expWks As Worksheet
  Dim Key As Variant
  Dim R As Long
  Dim StartCell As String
  
    Set expWks = Worksheets("exp")
    Set budWks = Worksheets("bud")
    
    Set expRng = expWks.Cells(1, 1).CurrentRegion
    Set expHeaders = expRng.Offset(0, 2).Resize(1, expRng.Columns.Count - 2)
     
    Set budRng = budWks.Cells(1, 1).CurrentRegion
    Set budHeaders = budRng.Offset(0, 2).Resize(1, budRng.Columns.Count - 2)
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
     'Save the "bud" headers in the lookup array
      For Each Cell In budHeaders
        Key = Trim(Cell)
        If Key <> "" Then
          If Not Dict.Exists(Key) Then
             Dict.Add Key, 1
          End If
        End If
      Next Cell
      
     'Check for any "exp" headers that are missing in the "bud" headers
      For Each Cell In expHeaders
        Key = Trim(Cell)
        If Key <> "" Then
         'Add a new column for the missing header
          If Not Dict.Exists(Key) Then
             C = budRng.Columns.Count
             budRng.Columns(C).EntireColumn.Insert
             budWks.Cells(1, C) = Key
          End If
        End If
      Next Cell
      
     'Clear the lookup array
      Dict.RemoveAll
    
     'Save the "exp" data and codes in the lookup array
      For R = 2 To expRng.Columns(1).Cells.Count
        For C = 3 To expRng.Columns.Count
          Key = Trim(expRng.Cells(R, 1) & expRng.Cells(1, C))
          If Key <> "" Then
            If Not Dict.Exists(Key) Then
               Dict.Add Key, expRng.Cells(R, C)
            End If
          End If
        Next C
      Next R
           
     'Fill in the "bud" sheet
      For R = 3 To budRng.Columns(2).Cells.Count Step 3
        For C = 3 To budRng.Columns.Count
          Key = Trim(budRng.Cells(R - 1, 1) & budRng.Cells(1, C))
          If Key <> "" Then
            If Dict.Exists(Key) Then
               budRng.Cells(R, C) = Dict(Key).Value
            End If
          End If
        Next C
      Next R
      
     'Add the sum formulas
      With budRng.Columns(budRng.Columns.Count - 1)
        StartCell = budRng.Cells(2, 4).Address(False, False)
        EndCell = .Cells(2, 1).Address(False, False)
        .Cells(2, 1).Offset(0, 1).Formula = "=SUM(" & StartCell & ":" & EndCell & ")"
        .Offset(1, 1).Resize(budRng.Rows.Count - 1, 1).FillDown
      End With
      
End Sub

[soso123]

Thanks alot Leith ... what about deff cells ??