Forum - VBA If, move and concatenate

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] If, move and concatenate (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/1246-if-move-concatenate.html)

If, move and concatenate

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

Θα ήθελα την βοήθεια σας.
Επισυνάπτω δείγμα 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

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

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

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

και πες μας

Παράθεση:

Αρχική Δημοσίευση από gr8styl (Μήνυμα 7150)

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

και πες μας

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

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

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

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

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

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

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

Κώδικας:



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