Consulting

Results 1 to 6 of 6

Thread: VBA problem

  1. #1

    VBA problem

    Good afternoon,

    i have the code in the attached excel file to copy data from sheet2 to sheet1 when the record numbers are matching: it works only if i run the macro from sheet1, but i would make it run from sheet2 (placing the button), any help?

    Another question: it would be possible to modify the code, adding a message error when, copying from sheet2 to sheet1, the destination cells in sheet1 are not empty?

    Thank you.
    Attached Files Attached Files

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    I'd do something like this


    Option Explicit
    
    
    Sub find_and_copy()
        Dim rFrom As Range, rTo As Range, r As Range
        Dim wsFrom As Worksheet, wsTo As Worksheet
        Dim n As Long
    
    
        Set wsFrom = Worksheets("From")
        Set wsTo = Worksheets("To")
    
    
        Set rFrom = wsFrom.Cells(1, 1).CurrentRegion
        Set rFrom = rFrom.Cells(2, 1).Resize(rFrom.Rows.Count - 1, rFrom.Columns.Count)
    
    
        Set rTo = wsTo.Cells(1, 1).CurrentRegion
    
    
        For Each r In rFrom.Columns(1).Cells
            
            n = 0
            On Error Resume Next
            n = Application.WorksheetFunction.Match(r.Value, rTo.Columns(1), 0)
            On Error GoTo 0
            
            If n > 0 Then
                If Application.WorksheetFunction.CountA(rTo.Rows(n)) > 1 Then
                    MsgBox r.Value & " in row " & n & " already has data"
                    
                Else
                    r.EntireRow.Copy wsTo.Cells(n, 1)
                End If
            End If
        Next
        
        Application.ScreenUpdating = True
        MsgBox "Finito"
            
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3

    inverted sheets

    Hi Paul,

    thanks for this, but you have inverted the sheets, i would need data from sheet "to" to sheet "from" and i am not sure how to change it.

  4. #4
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    The one bit that needs changing is an unqualified reference.
    Change:
    For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(A:A)])
    to:
    For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(Sheet1!A:A)])
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  5. #5
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Oops, forgot the second part; you can test if the destination cells are empty with:
    If rng1.Cells.Count = Application.CountBlank(rng1) Then

    In full:
    Sub find_and_copy()
    Dim ce As Range
    Dim f As Range
    Dim r As Long
    Dim rng1 As Range, rng2 As Range
    
    Application.ScreenUpdating = False
            
    For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(Sheet1!A:A)])
      Set f = Worksheets("Sheet2").Range("A:A").Find(ce, lookat:=xlWhole)
      If Not (f Is Nothing) Then
        r = WorksheetFunction.CountA(f.EntireRow)
        Set rng1 = Worksheets("sheet1").Range(Worksheets("sheet1").Cells(ce.Row, 5), Worksheets("sheet1").Cells(ce.Row, 3 + r))
        If rng1.Cells.Count = Application.CountBlank(rng1) Then
          Set rng2 = Worksheets("sheet2").Range(Worksheets("sheet2").Cells(f.Row, 2), Worksheets("sheet2").Cells(f.Row, r))
          rng1.Value = rng2.Value
        Else
          Application.Goto rng1 'to show the user the destination cells
          Application.ScreenUpdating = True
          MsgBox "destination cells are not empty"
          Application.ScreenUpdating = False
        End If
      End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Finito"
    End Sub
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  6. #6
    It works very good, thank you!

    Thank you ALL.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •