[VBA] If, move and concatenate

[devcon]

Καλημέρα και καλή εβδομάδα,

Θα ήθελα την βοήθεια σας.
Επισυνάπτω δείγμα Excel.
Θέλω να συνενώσω (concatenate) τα δεδομένα της στήλης Β στην B εάν η στήλη Α είναι κενή και δεν υπάρχει η λέξη “offer”, “Offer”, “OFFER” .
Στην περίπτωση που υπάρχει η λέξη “offer”, “Offer”, “OFFER” να μετακινηθούν (move) τα κελία από την Β στην Γ.
Χρησιμοποιώ την ακόλουθη macro αλλά δυστυχώς δεν είναι αρκετή και δεν εκπληρώνει όλα αυτά που ζητώ.

Sub MoveValues()

Dim thing As Range
Dim lastARow As Integer

'Determine last Cell In Column B
 lastARow = Range("B" & Rows.Count).End(xlUp).Row

'Loop through Column B
  For Each thing In Sheets(1).Range("B2:B" & lastARow)

'Look for OFFER and Offer
   If thing.Value Like "*OFFER*" Or _
      thing.Value Like "*Offer*" Then
      
'If not found, Move B to C then Clear B
    Cells(thing.Row, 3) = Cells(thing.Row, 2)
    Cells(thing.Row, 2) = ""
       
   Else
'If found, Do Nothing
      GoTo LeaveItAlone
   End If
LeaveItAlone:
 Next
  
'If empty
 ActiveCell.FormulaR1C1 = _
        "=IF(R[1]C[-6]="""", CONCATENATE(RC[-5], "" "", R[1]C[-5], "" "", R[2]C[-5]), INDIRECT(""B""&ROW()))"
    Range("G3").Select

End Sub

Ο τρόπος που εκθέτω το πρόβλημα μου να μην είναι ξεκάθαρος αλλά πολλές φορές ένα δείγμα όπως το συνημμένο θεωρώ ότι είναι καλύτερο από χίλιες λέξεις.

Σας ευχαριστώ εκ των προτέρων για την βοήθεια σας.

[gr8styl]

Φίλε συνονόματε για δες το συνημμένο (χωρίς VBA) αν σου κάνει.

και πες μας

[devcon]

Αρχική Δημοσίευση από gr8styl

Φίλε συνονόματε για δες το συνημμένο (χωρίς VBA) αν σου κάνει.

και πες μας

Θανάση συνονόματε σε ευχαριστώ για την απάντηση αλλά δεν είναι αυτό ακριβώς που θέλω.

Στην κολόνα Β πρέπει να είναι όλα τα στοιχεία τα οποία βρίσκονται όπου δεν υπάρχει νούμερο στην κολόνα Α (concatenate), αλλά εάν υπάρχει στην κολόνα Β η λέξη “Offer” ή “OFFER” να μεταφέρονται στην κολόνα Γ μέχρι τον επόμενο αριθμό που θα υπάρξει στην κολόνα Α.

Όλα αυτά πρέπει να βρίσκονται κάτω από μια μακροεντολή διότι ο πίνακα συνέχεια αλλά ανά πελάτη/προσφορά.

Για περισσότερες πληροφορίες δες το δείγμα excel.

[gr8styl]

Φίλε μου αν και από ότι κατάλαβα θέλεις λύση με VBA (το αφήνω για τους ειδικούς)
Ωστόσο μιας και για μένα αποτελεί πρόκληση το τι μπορούμε να κάνουμε χωρίς VBA,
δες και αυτό το συνημμένο Example_2.xls που νομίζω ότι κάνει το ζητούμενο.

Ελπίζω να έχω κατανοήσει το επιθυμητό.
Θανάσης Σ.

[devcon]

Αγαπητέ Θανάση,
Σε ευχαριστώ για την απάντησή σου.
Έλαβα την λύση και την παραθέτω για κάποιο άλλον που θα είχε το ίδιο πρόβλημα.

Option Compare Text
Option Explicit

Sub MoveValues()
Dim LR As Long
Dim Rw As Long
Dim MyStr As String
Dim MyOff As String

Application.ScreenUpdating = False  'Speeds up macro execution

'Determine last Cell In Column B
LR = Range("B" & Rows.Count).End(xlUp).Row

'Loop through Column B from the bottom up
    For Rw = LR To 2 Step -1
        If Cells(Rw, "A") = "" Then
            MyStr = Cells(Rw, "B") & " " & MyStr
            If InStr(MyStr, "offer") > 0 Then
                MyOff = MyStr
                MyStr = ""
            End If
        Else
            Cells(Rw, "C") = Application.WorksheetFunction.Trim(Cells(Rw, "B") & " " & MyStr)
            Cells(Rw, "D") = MyOff
            MyStr = ""
            MyOff = ""
        End If
    Next Rw

Range("C:D").WrapText = True
With Range("C1:D1")
    .Value = [{" Department","Offer"}]
    .Font.Bold = True
    .Borders(xlEdgeBottom).Weight = xlMedium
    .ColumnWidth = 43
End With

Application.ScreenUpdating = True
If MsgBox("Remove Old Data?", vbYesNo, "Confirm") = vbNo Then Exit Sub

Range("A3:A" & LR).SpecialCells(xlBlanks).EntireRow.Delete xlShiftUp
Range("B:B").Delete xlShiftToLeft

End Sub