Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 14 След.
Объединенить / СЦЕПИТЬ ячееки в умной таблице, macro, vba
 
Цитата
Alex D написал:
End колонки постоянно меняется от листа к листу
Значит,  это надо сделать для многих листов, а не только для одного ?
Объединенить / СЦЕПИТЬ ячееки в умной таблице, macro, vba
 
8) Вы написали этот код, и не знаете, как это сделать дальше ? 8)  ... вот шутник из вас ...  ;)  
Перенос количества определенных ячеек на другой лист
 
Если я правильно понял, например, так:
Код
Option Explicit

Sub abc_xyz()
    With Sheets("List2")
        With .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(.Range("C1").Value, 1)
            .Value = Sheets("List1").Range("I1:I" & .Parent.Range("C1").Value).Value
        End With
    End With
    With Sheets("List1")
        With .Rows("1:" & Sheets("List2").Range("C1").Value)
            .Delete
        End With
    End With
End Sub
Удаление объектов (Shape) находящихся в конкретном диапазоне листа.
 
Цитата
БМВ написал:
Это мы с Дмитрием обсудили
Я не всё прочитал ... признаю ...

Цитата
БМВ написал:
будут строки вставляться
Что с 'Shape.Placement Property' ?

Цитата
БМВ написал:
Intersect(Shape.TopLeftCell, Cell)
Не будет ли лучше (?):
Код
If Intersect(cell, Range(shp.TopLeftCell, shp.BottomRightCell)) ...
тогда или "перед" или "зад" могут выступать за ячейку



Редакт.

??? прямо по имени ???
Код
Sub udali_kartinku_balbinku()
    Dim i%, idx%, j%, jdx%
    Dim diap, kart
    
    diap = Array("A", "B", "F", "K")
    idx = UBound(diap)
    kart = Array(1, 4, 5, 7, 9, 10, 12, 13, 17, 24)
    jdx = UBound(kart)
    
    With Sheets("List1")
        For i = 0 To idx
            For j = 0 To jdx
                .Shapes(diap(i) & "_" & kart(j) & "_kart").Delete
            Next
        Next
    End With
End Sub
Изменено: ocet p - 21 Фев 2020 00:39:09
Удаление объектов (Shape) находящихся в конкретном диапазоне листа.
 
Цитата
БМВ написал:
при наличии множества объектов, оптимально найти и удалить один или несколько объектов
Если имя фигуры будет содержать адрес ячейки, в которую была вставлена ​​эта фигура, то найти и удалить её будет очень легко - только, вам нужно сначала навести порядок (уладить, упорядочить) в именах фигур.
Выбор из текста в ячейке данных по конкретным парметрам
 
Цитата
Аналитик2 написал:
50:20:0030102:1858, площадью 59,4 кв.м., кв. 138, адрес
... несогласованность/несоответствие данных ... : ( ... в то же время и десятичный разделитель и разделитель списка ... : (
Ошибка 1004 при вставке текста в объединенную ячейку
 
Если у вас есть, например, объединенная ячейка "С5" ("С5:Е8"), то попробуйте это:
Код
Sub clop_plank()
    With ThisWorkbook
        .Activate
        With .Worksheets("List1")
            .Select
            With .Range("C5")
                If .MergeCells Then .MergeArea.UnMerge
                .Select
            End With
            ActiveSheet.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
            Application.CutCopyMode = False
            'With .Range("B11:C14").Interior
            '    .Pattern = xlSolid
            '    .PatternColorIndex = xlAutomatic
            '    .Color = 65280
            '    .TintAndShade = 0
            '    .PatternTintAndShade = 0
            'End With
            .Range("B22").Select
        End With
    End With
End Sub
Ошибка 1004 при вставке текста в объединенную ячейку
 
?
Ну ... и вот так должно быть с объединенными ячейками
?

А в чем вам нужна помощь ?
Можно ли группировать строки по номерам
 

Посмотрите пожалуйста тут:

https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=124283&a...

код gling - не подходит (?), ведь можно модифицировать ...

Функция сжать пробелы макросом (VBA)
 
Цитата
Andrey Ka написал:
данные в виде цифр
В виде (= формате) или просто это числа ?

? Replace() ?
Построчно прочитать текстовый файл с кириллицей в utf-8, вывести его содержимое на листе.
 
Цитата
elegi2003 написал:
файл достаточно большой, а мне нужны не все подряд строки, а только некоторые
Зачем сразу не написали ?
Так каков размер этого файла, что он не подходит excel ?
Попробуйте так, но вы не предоставили достаточно информации о файлах для обработки:
Код
Option Explicit

Sub utfe_8()
    Const fltr = "CSV Files (*.csv),*.csv,TXT Files (*.txt),*.txt"
    '--------------------------------------------------------------
    ' https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/stream-object-ado?view=sql-server-ver15
    ' ADODB.Stream
    '--------------------------------------------------------------
    'Charset => HKEY_CLASSES_ROOT\MIME\Database\Charset
        Const chrst = "utf-8"
    'StreamTypeEnum
        Const adTypeBinary = 1
        Const adTypeText = 2
    'SaveOptionsEnum
        Const adSaveCreateNotExist = 1
        Const adSaveCreateOverWrite = 2
    'StreamWriteEnum
        Const adWriteChar = 0
        Const adWriteLine = 1
    'StreamReadEnum
        Const adReadAll = -1 ' The default value
        Const adReadLine = -2
    'LineSeparatorsEnum
        Const adCR = 13
        Const adLF = 10
        Const adCRLF = -1
    '--------------------------------------------------------------
    Dim fle
    fle = Application.GetOpenFilename(fltr, 2, "UTF-8", , False)
    If TypeName(fle) = "Boolean" Then Exit Sub
    'fle = "C:\Temp\PrimerUTF-8.txt"
    'fle = Right(fle, Len(fle) - InStrRev(fle, "\", -1, 1))
    '--------------------------------------------------------------
    Dim r&, strline, utf8 As Object
    '--------------------------------------------------------------
    Set utf8 = CreateObject("ADODB.Stream")
    utf8.Type = adTypeText
    utf8.Charset = chrst
    utf8.LineSeparator = adCRLF
    utf8.Open
    'utf8.LoadFromFile ThisWorkbook.Path & "\" & fle
    utf8.LoadFromFile fle
    '--------------------------------------------------------------
    utf8.Position = 0 ' posle 'LoadFromFile' ne obyazatel'no
    '--------------------------------------------------------------
    Do Until utf8.EOS
        strline = utf8.ReadText(adReadLine)
        If Trim(strline) <> "" Then
            If strline Like "##." Or strline Like "*####*" Then
                'MsgBox Left(strline, 32)
                '???
            Else
                r = r + 1
                Range("A" & r).Value = Application.Clean(strline)
            End If
        End If
    Loop
    '--------------------------------------------------------------
    utf8.Close
    Set utf8 = Nothing
End Sub

Работает с тестовым файлом:
Построчно прочитать текстовый файл с кириллицей в utf-8, вывести его содержимое на листе.
 
Почему макрос ?
Например:
Данные => Импорт из текстового файла => Кодирование 65001 (UTF _ 8 .)
Изменено: ocet p - 8 Фев 2020 01:36:40
VBA. Извлечение данных между символами
 

Допущения (Предположения, Основа ???):

1. Таблица начинается в строке 1
2. Данные начинаются в строке 2
3. Данные распознаются на основе фиксированного скелета (фиксированной основы)
4. Данные с повторяющимися номерами GTD симметричны
  Это значит что, номеров GTD столько же, сколько их аналогов с кодом страны и количеством ... и наоборот
5. В случае нескольких номеров GTD, исключений нет.
  Если, например, есть 3 номера GTD, то будет такое же количество кодов стран и названий стран, что и номера GTD.
  Схема есть схема, а не исключение от неё - "орднунг мусс зайн"

(как это будет работать с другими схемами данных не знаю)

Пс:
Вообще-то эта тема более для использования регулярных выражений - но, пожалуйста, попробуйте обычный код:

Код
Option Explicit

Sub abc_xyz()
Const sch1 = "*/*/*/*;[A-Z][A-Z]"
Const sch2 = "*/*/*/*, Q*.*;[A-Z][A-Z]"
Const sch3 = "*/*/*/*, Q*.*;*;[A-Z][A-Z], Q*.*;*"
    
    Dim i%, idx%, j%, jdx%, pos%
    Dim cntrstr$, gtdnr$, kodstr$, nzstr$, sstr$
    Dim rplc, splt, tbl, tblcntr, tblpos
    
    With Sheets("Country List").Range("A1").CurrentRegion
        tblcntr = .Offset(1, 0).Resize(.Rows.Count - 1, 3).Value
        tblpos = .Columns("B").Offset(1, 0).Resize(.Columns("B").Rows.Count - 1, 1).Value
    End With
    
    With Sheets("GTD").Range("A1").CurrentRegion.Columns("D")
        tbl = .Offset(1, 0).Resize(.Rows.Count - 1, 1).Value: idx = UBound(tbl, 1)
    End With
    
    For i = 1 To idx
        sstr = Replace(Replace(Trim(tbl(i, 1)), Chr(10), "", 1, -1, 1), Chr(13), "", 1, -1, 1)
        
        If sstr <> "" Then
            rplc = Replace(sstr, ",", ".", 1, -1, 1): sstr = ""
            rplc = Replace(rplc, "/[", ";", 1, -1, 1): rplc = Replace(rplc, "+", ";", 1, -1, 1)
            rplc = Replace(rplc, "]", ",", 1, -1, 1): rplc = Replace(rplc, "[", "", 1, -1, 1)
            rplc = Replace(rplc, ";EA", "", 1, -1, 1): rplc = Replace(rplc, ",;", ";", 1, -1, 1)
            If Right(rplc, 1) = "," Then rplc = Left(rplc, Len(rplc) - 1)
            rplc = Replace(rplc, ",", ", ", 1, -1, 1)
            
            splt = Split(rplc, ";", -1, 1)
            
            If Not IsEmpty(splt) Then
                If rplc Like sch1 Or rplc Like sch2 Then
                    pos = Application.Match(splt(1), tblpos, 0)
                    If Not IsError(pos) Then
                        If InStr(1, splt(0), ",", 1) > 0 Then sstr = "," & Split(splt(0), ",", -1, 1)(1)
                        nzstr = Application.Index(tblcntr, pos, 1) & sstr
                        kodstr = Application.Index(tblcntr, pos, 3)
                        splt = Array(splt(0), kodstr, nzstr)
                    End If
                    pos = 0: If sstr <> "" Then sstr = ""
                    
                ElseIf rplc Like sch3 Then
                    jdx = UBound(splt) \ 2
                    For j = 0 To jdx
                        gtdnr = gtdnr & splt(j) & ";" & Chr(10)
                        If InStr(1, splt(jdx + j + 1), ",", 1) > 0 Then
                            cntrstr = Split(splt(jdx + j + 1), ",", -1, 1)(0)
                            pos = Application.Match(cntrstr, tblpos, 0)
                            If Not IsError(pos) Then
                                nzstr = Application.Index(tblcntr, pos, 1)
                                sstr = sstr & Replace(splt(jdx + j + 1), cntrstr, nzstr, 1, -1, 1) & ";" & Chr(10)
                                kodstr = kodstr & Application.Index(tblcntr, pos, 3) & ";" & Chr(10)
                            End If
                            cntrstr = "": pos = 0
                        End If
                    Next
                    splt = Array(Left(gtdnr, Len(gtdnr) - 2), Left(kodstr, Len(kodstr) - 2), Left(sstr, Len(sstr) - 2))
                    
                End If
            End If
        End If
        
        If IsEmpty(rplc) Then splt = Array("'-", "'-", "'-") Else rplc = Empty
        Sheets("GTD").Range("E" & i + 1).Resize(1, 3).Value = splt: splt = Empty
        If gtdnr <> "" Then gtdnr = ""
        If sstr <> "" Then sstr = ""
        If kodstr <> "" Then kodstr = ""
    Next
    
    tbl = Empty: tblcntr = Empty: tblpos = Empty
End Sub

VBA. Извлечение данных между символами
 
Цитата
Мария - написал: Имеем Номер ГТД
Всегда будет сохранена схема "]Q2.000+[" или "]Q4,000/[" между основными частями кода GTD, или здесь могут быть другие буквы чем "Q" и символы "+", "/" ?
Сборка первых листов из разных книг в один файл - один лист
 
Может быть таким образом ?
Код
Option Explicit

Sub a_soberi_dannyye()
    Const shBD = "Baza"
    Const dpznbgBD = "A1"       ' => nachalo diapazona lista "Baza"
    Const dpznbgistnk = "A1"    ' => nachalo diapazona istochnikov
    ' 'clsmax' => kolichestvo stolbtsov dlya kopirovaniya iz diapazona istochnikov
    Const clsmax = 28           ' => simvolicheskoye "A:AB"
    Const ffltr = "All files (*.*), *.*,Excel files (*.xls**), *.xls**"
    
    Dim fto: fto = Application.GetOpenFilename(ffltr, 2, "Files to Merge", , True)
    If TypeName(fto) = "Boolean" Then
        MsgBox "?! @$&#^*&^%*#%&^#%*&#%&_(*(*#%&#%& ?! .... !!!!!!!!" ' ... :)
        Exit Sub
    End If
    
    Dim thswb$, fle, tbl, exl As Object, thswbsh As Object
    
    With ThisWorkbook
        thswb = .Name
        Set thswbsh = .Sheets(shBD)
    End With
    
    Application.ScreenUpdating = False
    
    For Each fle In fto
        If Right(fle, Len(fle) - InStrRev(fle, "\", -1, 1)) <> thswb Then
            Set exl = GetObject(fle)
            With exl
                'Windows(.Name).Visible = True 'Tol'ko dlya testirovaniya
                With .Worksheets(1).Range(dpznbgistnk).CurrentRegion.Columns
                    tbl = .Offset(1, 0).Resize(.Rows.Count - 1, clsmax).Value
                End With
                'Windows(.Name).Visible = False 'Tol'ko dlya testirovaniya
                .Close False
            End With
            Set exl = Nothing
            With thswbsh.Range(dpznbgBD).CurrentRegion.Columns(1)
                .Offset(.Rows.Count, 0).Resize(UBound(tbl, 1), clsmax).Value = tbl: tbl = Empty
            End With
        End If
    Next
    
    thswbsh.Range(dpznbgBD).CurrentRegion.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub
Сборка первых листов из разных книг в один файл - один лист
 
Всегда ли в книге (Файл_1, Файл_2, Файл_3, Файл_n) будет только один лист ?
Макрос расчета количества значений из данных таблицы
 
Надо чтобы таблица начиналась с "A1", а как есть у вас ?

tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Код
tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Макрос расчета количества значений из данных таблицы
 

Пожалуйста проверьте это, будет ли у вас работать или нет ?

У меня, что-то не хотело сотрудничать/работать с вашей кирилицей (названия городов и названия листов - они не хотели сортировать правильно и взаимо узнавать) - надо мне было всё изменить на латиницу - у вас, наоборот замените на кириллицу это: "List1", "Kolichestvo", "Gorod", "UROiK1", "UROiK2", "UROiK3", "Itogo". Код, написанный в "разделах", чтобы вам было легче вносить в него исправления, если бы "что-то случилось".

Код
Option Explicit

Sub abc_xyz()
    Const datasht = "List1"
    Const rsltcell = "G1" 'Tut budet resul'tat raboty makrosa
    
    Dim i&, idx&, j&, k&, dict, itm, ky, tbl
    '--------------------------------------------------------------------------
    With ThisWorkbook.Sheets(datasht)
        tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
    idx = UBound(tbl, 1)
    For i = 1 To idx
        If Trim(tbl(i, 3)) <> "" Then tbl(i, 3) = 1 Else tbl(i, 3) = 0
        If Trim(tbl(i, 4)) <> "" Then tbl(i, 4) = 1 Else tbl(i, 4) = 0
        If Trim(tbl(i, 5)) <> "" Then tbl(i, 5) = 1 Else tbl(i, 5) = 0
    Next
    '--------------------------------------------------------------------------
    For i = 1 To idx - 1
        For j = i + 1 To idx
            If tbl(i, 2) & ";" & tbl(i, 1) > tbl(j, 2) & ";" & tbl(j, 1) Then
                For k = 1 To 5
                    ky = tbl(j, k)
                    tbl(j, k) = tbl(i, k)
                    tbl(i, k) = ky
                Next
            End If
        Next
    Next
    '--------------------------------------------------------------------------
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To idx
        ky = tbl(i, 2) & ";" & tbl(i, 1)
        If Not dict.Exists(ky) Then dict(ky) = 1
    Next
    k = dict.Count: dict.RemoveAll: Set dict = Nothing
    '--------------------------------------------------------------------------
    dict = Empty: ReDim dict(1 To k, 1 To 4): k = 1
    dict(1, 1) = tbl(1, 2) & ";" & tbl(1, 1)
    For j = 2 To 4
        dict(1, j) = tbl(1, j + 1)
    Next
    For i = 2 To idx
        ky = tbl(i - 1, 2) & ";" & tbl(i - 1, 1)
        itm = tbl(i, 2) & ";" & tbl(i, 1)
        If itm <> ky Then
            k = k + 1
            dict(k, 1) = itm
            For j = 2 To 4
                dict(k, j) = tbl(i, j + 1)
            Next
        Else
            For j = 2 To 4
                If dict(k, j) = 0 And tbl(i, j + 1) = 1 Then dict(k, j) = 1
            Next
        End If
    Next
    '--------------------------------------------------------------------------
    tbl = Empty: j = 0: ReDim tbl(1 To k, 1 To 4)
    For i = 1 To k Step 3
        j = j + 1
        tbl(j, 1) = Split(dict(i, 1), ";", -1, 1)(0)                 'Gorod
        tbl(j, 2) = dict(i, 2) + dict(i, 3) + dict(i, 4)             'UROiK1
        tbl(j, 3) = dict(i + 1, 2) + dict(i + 1, 3) + dict(i + 1, 4) 'UROiK2
        tbl(j, 4) = dict(i + 2, 2) + dict(i + 2, 3) + dict(i + 2, 4) 'UROiK3
    Next
    dict = Empty
    '--------------------------------------------------------------------------
    With ThisWorkbook.Sheets(datasht)
        With .Range(rsltcell)
            If .MergeCells Then .MergeArea.UnMerge
            .Value = "Kolichestvo"
            .Offset(1, 0).Resize(1, 4).Value = Array("Gorod", "UROiK1", "UROiK2", "UROiK3")
            .Offset(2, 0).Resize(j, 4).Value = tbl: tbl = Empty
            .Offset(j + 2, 0).Value = "Itogo"
            .Offset(j + 2, 1).Resize(1, 3).FormulaR1C1 = "=SUM(R[-" & j & "]C:R[-1]C)"
            .Resize(1, 4).Merge (True)
        End With
    End With
End Sub
Макрос расчета количества значений из данных таблицы
 
Напишите пожалуйста, как это будет выглядеть (как это "будет суммированным") в следующем списке (картинка):
Макрос расчета количества значений из данных таблицы
 

nor,

Почему у вас есть этот результат для "Ставрополь" ?

Город УРОиК1 УРОиК2 УРОиК3
Ставрополь     2     0     2

, если в таблице есть что-то другое ?

Подразделение Город Спуск1 Спуск2 Спуск3
УРОиК1 Ставрополь     1     1
УРОиК2 Ставрополь
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
...
Должно быть вероятно (скорее всего ?) так:

Город УРОиК1 УРОиК2 УРОиК3
Ставрополь     1     0     4
...
Не понимаю этих ваших "УРО(и)КОВ" ..... : ( ... ??? ... : (

Изменено: ocet p - 2 Фев 2020 00:34:50
Расчет ближайшей даты доставки при определенных условиях
 
Я не знаю, правильно ли я понял, но это может выглядеть так:
Код
Function datadost(rRng, crit, dDate)
    Dim cls%, arr, c, i&
    i = crit.Row
    cls = rRng.Columns.Count
    arr = Range(rRng.Columns(2), rRng.Columns(cls)).Rows(1).Value
    c = Application.Match(Format(dDate, "ddd"), arr, 0): arr = Empty
    If IsError(c) Then datadost = CVErr(xlErrNA): Exit Function
    arr = Range(rRng.Columns(2), rRng.Columns(cls)).Rows(i).Value
    cls = UBound(arr, 2): i = 0
jr: For c = c To cls
        If Trim(arr(1, c)) <> "" Then Exit For
        i = i + 1
    Next
    If i = UBound(arr, 2) Then datadost = CVErr(xlErrNA): Exit Function
    If c > cls Then cls = c - i - 1: c = 1: GoTo jr
    datadost = dDate + i + arr(1, c): arr = Empty
End Function

но, кроме вашего примера, не проверено.

функция должна быть скопирована в стандартный модуль редактора vba (Alt+F11 => Insert \ Module), например, "Module1".

Вызов функции на листе (например в "I2" и скопировать вниз) - для вашего примера:

Код
=datadost($A$1:$H$4;$A2;СЕГОДНЯ())
$A$1:$H$4 - это ваша таблица - целая
$A2 - конкретный магазин

Пс:
Я не знаю, будет ли "Format(dDate, "ddd")" работать правильно с кириллицей (и в результате возвращать правильный символ дня недели: пн, вт, ...).
Изменено: ocet p - 30 Янв 2020 14:35:46
Макрос. Открытие конкретной записи в word при слиянии
 
?
Для этого вам просто хватит обычная функция листа - если файлы находятся в одном каталоге, то указывать даже путь не нужно.
'B4'
Код
 =HYPERLINK(A4 & ".docx")
Расчет ближайшей даты доставки при определенных условиях
 
Обязательно ли это должна быть формула листа ?
Сделать такую ​​формулу будет довольно сложно даже с помощью вспомогательных столбцов.
Может ли это быть "UDF-формула" (vba) ?
В макросе вместо заменяемого текста указать ячейку с текстом
 
? А может быть так ?
Код
Sub abc_xyz()
    With Columns("C")
        Dim rab As Range: Set rab = .Find("раб", .Range("A" & .Rows.Count), xlValues, xlPart, xlByRows)
    End With
    If Not rab Is Nothing Then
        Range("A:A,C:C").Replace Range(rab.Address(0, 0)).Value, ".", xlPart, xlByRows
    End If
End Sub
Залить блок цветом, если в нем есть закрашенная строка
 
Цитата
vaniok95 написал:
блок информации
Напишите пожалуйста как нам на самом деле различить что такое для вас блок информации а что не - содержательный пример в xls был бы желателен.
Автозаполнение с ссылками на другой лист
 
Пожалуйста, можете попробовать этот способ - Вставьте в "B2" (но вам нужно изменить названия магазинов):
Код
=INDIRECT(ADDRESS(COLUMN(B2),4,4,1,$A2))
=ДВССЫЛ(АДРЕС(СТОЛБЕЦ(B2);4;4;1;$A2))
Отображать в ячейках диапазона формулы
 
Добрый вечер,

Можете ли вы привести какой-либо пример данных с желаемым результатом ?
Разбитие текста в ячейке для заполнение текстбоксов
 
Например:
Код
Option Explicit

Private Sub UserForm_Initialize()
    Dim primer
    primer = "12,25" '<= eto est' eta vasha yacheyka naprimer => primer = Range("A1").Value
    
    With UserForm1
        'Variant 1
        .TextBox1.Text = Split(primer, ",", -1, 1)(0)
        .TextBox2.Text = Split(primer, ",", -1, 1)(1)
        
        'Variant 2
        .TextBox1.Text = Left(primer, InStr(1, primer, ",", 1) - 1)
        .TextBox2.Text = Right(primer, Len(primer) - InStr(1, primer, ",", 1))
        
        'Variant 3
        .TextBox1.Text = Val(primer)
        .TextBox2.Text = Mid(primer, InStr(1, primer, ",", 1) + 1, Len(primer) - InStr(1, primer, ",", 1))
        
        'Variant 4
        primer = Split(primer, ",", -1, 1)
        .TextBox1.Text = primer(0)
        .TextBox2.Text = primer(1)
        
        'itd.
    End With
End Sub
Перенос данных из объединенных ячеек одного документа в одну ячейку другого документа. VBA, Макрос VBA
 
Цитата
EleeSha написал:
великие умы
:)  ... гмм ... к счастью, у меня пока нет гидроцефалии ... но есть асцит ... от пива ...  :)

А что делать с остальными столбцами (Направление, 1,2,3,4,5 и т. д.) ?
Ну, и в "Графике" 3 строки для каждой линии данных а в "Табельном" только две, как вписать 3 строки в 2 ?


Пс:
Вам придется использовать свойства: MergeArea и MergeCells, а также конструкции типа "Range.Сells(x,y)" => MergeArea.Cells(1,2), и т. д.
Макрос копирования и вставки по условию.
 
? Это что-то подобное ?
Код
'модуль ThisWorkbook
Private Sub Workbook_Open()
    Sheets("Лист1").Select
    Range("A1").Select
End Sub

'модуль Лист1
Private Sub Worksheet_Activate()
    Sheets("Лист1").Select
    Range("A1").Select
End Sub

'модуль Лист1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target.Cells(1), Range("H5:N5,H8:N8,H11:N11")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
        Range("P" & Target.Cells(1).Row).Value = Target.Cells(1).Value
        Select Case Target.Cells(1).Row
            Case 5: Call Зеленый1
            Case 8: Call Зеленый2
            Case 11: Call Зеленый3
            Case Else: Application.EnableEvents = True: Exit Sub
        End Select
        Range("A1").Select
    Application.EnableEvents = True
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 14 След.
Наверх