Страницы: 1
RSS
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Уважаемые форумчане,

прошу помочь дописать код. Пример с кодом в приложении.
Мне бы хотелось, чтобы макрос смещал слова влево и повторял действие до тех пор,пока все слова не окажутся в одной строчке без пустых ячеек между словами. и так по всем строчкам.
на данный момент макрос смещает слова влево, но не повторяет действие несколько раз. мне кажется здесь надо как-то вписать Do until Loop. Я пыталась, но не получилось. Может кто-то может помочь?

Заранее благодарю
Екатерина
 
Цитата
на данный момент макрос смещает слова влево
А где макрос?
 
stranno on dolzhen bit vo vlozhennom faile:


Sub smeshenie_slov()
Dim i As Integer
Dim k As Integer
Dim lr As Long
Dim lcol As Long


lr = Worksheets("A").cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr

lcol = Worksheets("A").cells(i, Columns.Count).End(xlToLeft).Column
For k = 2 To lcol

If cells(i, k) = "" And cells(i, k + 1) <> "" Then
Range(cells(i, k + 1).Address).Select
Selection.Cut
Range(cells(i, k).Address).Select
ActiveSheet.Paste

Else
End If

Next k
Next i


End Sub
 
Код
Sub iDelEmpty()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 For i = 1 To iLastRow
   iLastCol = Cells(i, Columns.Count).End(xlToLeft).Column
  If iLastCol > 1 Then
    Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete
   End If
 Next
End Sub
Изменено: Kuzmich - 11.10.2020 17:35:07
 
Спасибо большое за ответ, Kuzmich! К сожалению, код не совсем смещает слова, а перемещает на другие строчки. Допустим если в строке A5 три слова через пустую ячейку, он перемещает слово на другую строку. Код не должен переписывать слова, а лишь сдвигать влево на первую свободную ячейку в строке. Так чтобы в итоге не было пустых ячеек между словами в строке.
заранее благодарю за ответ!
 
Цитата
если в строке A5 три слова через пустую ячейку, он перемещает слово на другую строку
Покажите в примере
 
primer do primeneniya makrosa
applesapplesapples
xxxstrawberrywatermelon
strawberrywatermelon
pears
appleswatermelonwatermelon
kak dolzhno bit:
applesapplesapples
xxxstrawberrywatermelon
strawberrywatermelon
pears
appleswatermelonwatermelon
Изменено: Екатерина - 11.10.2020 17:55:44 (nekorrektoe kopierivanie)
 
Макрос переносит последние два слова watermelon на строчку выше
 
Екатерина,
Вы покажите в примере, где
Цитата
он перемещает слово на другую строку
 
Proshu procheniya, srazu ne ponyala. Visilayu primer, v nem list kak dolzhno bit.
 
Попробуйте заменить строку
Код
If iLastCol > 1 Then

на
Код
If WorksheetFunction.CountA(Range(Cells(i, 2), Cells(i, iLastCol))) < iLastCol - 1 Then
 
Доброе время суток
Kuzmich, может дедовским способом для выделенной прямоугольной области и массивами. Ну их эти формулы рабочего листа?
Код
Public Sub CompressWordsToLeft()
    Dim i As Long, k As Long, pos As Long
    Dim vData, arrOut() As Variant
    vData = Selection.Value
    ReDim arrOut(1 To UBound(vData, 1), 1 To UBound(vData, 2))
    For i = 1 To UBound(vData, 1)
        pos = 0
        For k = 1 To UBound(vData, 2)
            If Not IsEmpty(vData(i, k)) Then
                pos = pos + 1
                arrOut(i, pos) = vData(i, k)
            End If
        Next
    Next
    Selection.Value = arrOut
End Sub
 
спасибо большое за ответы. Я поменяла строку в коде, как написал Kuzmich.Код работает только на пример 2. Как только я меняю количество пустых ячеек между словами, макрос сдвигает слова,но пустые ячейки все равно остаются. Вкладываю новый пример и как должно быть.
Макрос от Andrey VG -также огромное спасибо!- выдает ошибку, когда я запускаю макрос
ReDim arrOut(1 To UBound(vData, 1), 1 To UBound(vData, 2))
что то в этой строке ему не нравится.
Благодарю за помощь
 
Цитата
Екатерина написал:
выдает ошибку, когда я запускаю макрос
Подобная ошибка возникает, если вы не выделили диапазон ячеек, с которым необходимо произвести требуемую операцию.
 
Код
 Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
 
Спасибо большое! Оба варианта работают хорошо теперь.
С уважением,
Екатерина
Страницы: 1
Наверх