Вставка в Excell данных мультиметра из буфера обмена

@Rechnick · Регистрация: 19.04.2023

Студворк — интернет-сервис помощи студентам

Добрый день!

Подскажите как из буфера обмена вставлять данные и кое что в них ихменить.

Мультиметр записывает результаты измерений в свою таблицу, в качестве разделителей использует точки.
Подряд идут замеры сопротивлений одной платы с двух сторон.

Копирую результаты измерений в буфер обмена.
Делаю активной ячейку в таблице на листе "test" где хочу вставить результаты.
Запускаю макрос. Он должен вставить из буфера обмена в лист "Source".

В результатах измерения(3-й столбец) меняет точки на запятые.

Данные копирует, и вставляет на лист "test".
Этот столбец выравниваем по ширине.

Вторая половина измерений переносится на 2 столбца вправо.
в первых ячейках пишет 100 000
последние числа делит на 10.
Конец макроса.
Образец данных на отдельном листе "образец данных с мультиметра".

У меня вот какая получилась каша:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub Макрос4()
'
' Макрос4 Макрос
'
' Сочетание клавиш: Ctrl+й
'
    Sheets("source").Select
    ActiveSheet.Paste Range("A1")
    ActiveCell.Range("A1:A18").Select
    Application.CutCopyMode = False
     Dim a
    a = Range("B2:B19").Replace(".", ",", 2)
    Selection.Copy
    Sheets("test").Select
    ActiveSheet.Paste
    
    ActiveCell.Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "100000"
    ActiveCell.Offset(8, 0).Range("A1").Select
    ActiveCell = ActiveCell / 10
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "100000"
    ActiveCell.Offset(8, 0).Range("A1").Select
    ActiveCell = ActiveCell / 10
     ActiveCell.Offset(-17, 0).Range("A1:A18").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    ActiveCell.Offset(9, 0).Range("A1:A9").Select
    Selection.Copy Destination:=ActiveCell.Offset(0, 2).Range("A1:A9")
    ActiveCell.Range("A1:A9").Select
    Selection.ClearContents
    End Sub

@Rechnick · 03.05.2023, 12:24 **[ТС]**

Да, всегда две группы по 9 измерений.
Только данные вношу в таблицу, по горизонтали смещаясь вправо.
Теперь хочу либо копировать вторую половину измерений, вместо переноса, так как тогда форматирование ломаю,
либо потом границы дорисовывать.

@Rechnick · 03.05.2023, 12:31 **[ТС]**

Вот так заполняю таблицу, по мере измерений.

@АЕ · 03.05.2023, 12:52

Rechnick, вот мой код. Если не попал но нужным ячейкам его легко поправить.
Работает напрямую с буфером обмена. Ничего в промежуточный лист вставлять не надо.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Sub ttt()
    Dim s As String, d, x
    s = Clipboard_GetText()
    d = Text2Array(s)
    For i = LBound(d, 1) To UBound(d, 1) ' row
        For j = LBound(d, 2) To UBound(d, 2) ' col
        Select Case j
        Case 3
        If i < 10 Then x = 2 Else x = 4
        If i = 1 Or i = 10 Then
            Cells(i + 2, x) = 100000
        Else
            If d(i, 4) = "MOhm" Then
                Cells(i + 2, x) = Val(d(i, j)) * 1000
            Else
                Cells(i + 2, x) = Val(d(i, j))
            End If
        End If
        End Select
        Next j
    Next i
End Sub

Использую 2 вспомогательные функции для получения буфера и переброски его в массив.

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Function Text2Array(ByVal txt$, Optional ByVal ColumnsSeparator$ = " ", Optional ByVal RowsSeparator$ = vbNewLine) As Variant
    ' получает в качестве параметров текстовую строку TXT,
    ' и разделители строк и столбцов для разбиваемой строки
    ' Возвращает двумерный массив - результат разбиения строки
    txt = Trim(txt): On Error Resume Next: Err.Clear
    If txt Like "*" & RowsSeparator$ Then txt = Left(txt, Len(txt) - Len(RowsSeparator$))
    
    tmpArr1 = Split(txt, RowsSeparator$): RowsCount = UBound(tmpArr1) + 1
    ColumnsCount = UBound(Split(tmpArr1(0), ColumnsSeparator$)) + 1
    
    If Err.Number > 0 Then MsgBox "Строка не может быть разбита на двумерный массив", vbCritical: End
    ReDim arr(1 To RowsCount, 1 To ColumnsCount)
    
    For i = LBound(tmpArr1) To UBound(tmpArr1)
        tmpArr2 = Split(Trim(tmpArr1(i)), ColumnsSeparator$)
        For j = 1 To ColumnsCount
            arr(i + 1, j) = tmpArr2(j - 1)
        Next j
    Next i
    Text2Array = arr
End Function
    
Public Function Clipboard_GetText() As String
    On Error GoTo Error_Handler
    
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Clipboard_GetText = .GetText
    End With
    
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
    
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
    "Error Number: " & Err.Number & vbCrLf & _
    "Error Source: Clipboard_GetText" & vbCrLf & _
    "Error Description: " & Err.Description & _
    Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
    , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Добавлено через 4 минуты

Сообщение от Rechnick

по горизонтали смещаясь вправо.

тогда код надо подправить - x получать из активной ячейки или вводить через инпут
додумайте сами.

@Rechnick · 03.05.2023, 14:50 **[ТС]**

Вот немного макрос подправил, чтобы при переносе данных не вырезать а копировать. Форматирование не ломается.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
 Sheets("1").Select                        'выбор активного листа "1"
   Range("A1").Select                             'выбор первой ячейки на листе
   Range("A1:F18").Activate                         'делаем активным диапазон в левом верхнем углу
    ActiveSheet.Paste                               'вставка массива данных из буфера обмена
    ActiveCell.Offset(0, 0).Range("A1:A18").Select  'выбираем  левый столбец в листе
    Dim a                                           ' задаем массив для  замены точек на запятые
    a = Range("B1:D18").Replace(".", ",", 2)        'приравниваем диапазон с запасом массиву и меняем точки на запятые
    Sheets("1").Select                         'выбираем лист "1"
    Range("C1:C18").Select                          'выбираем третий столбец с сопротивлениями
    Application.CutCopyMode = False                 'режим  CUT при копировании отключен
    Selection.Copy                                  'копируем выбранный диапазон
    Sheets("КРП 6A").Select                           'переходим на лист "КРП 6A"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                'вставляем только данные из скопированных ячеек. Форматирование не ломаем.
    'ActiveSheet.Paste                               '
    
     With Selection
        .HorizontalAlignment = xlCenter             'центруем по горизонтали скопированные ячейки
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.Select                               'делаем активной первую ячеку из скопированных
    Application.CutCopyMode = False
    If ActiveCell = 0 Then ActiveCell.FormulaR1C1 = "100000" 'если при замере была бесконечность, то пишем 100 000 кОм
      'ActiveCell.FormulaR1C1 = "100000"
     ActiveCell.Offset(8, 0).Range("A1").Select     'опускаемся на 8 ячеек.
    ActiveCell = ActiveCell / 10                    'мультиметр передает число в   мОм, переводим в кОм.
    Selection.NumberFormat = "0"               ' оставляем только целые числа в форатировании, запятые в мОмах лишние
    ActiveCell.Offset(1, 0).Range("A1").Select      'опускаемся на одну ячейку вниз
    If ActiveCell = 0 Then ActiveCell.FormulaR1C1 = "100000" 'если при замере была бесконечность, то пишем 100 000 кОм
    'ActiveCell.FormulaR1C1 = "100000"
    ActiveCell.Offset(8, 0).Range("A1").Select      ' опускаемся на 8 ячеек вниз
    ActiveCell = ActiveCell / 10                    'мультиметр передает число в   мОм, переводим в кОм.
    Selection.NumberFormat = "0"               ' оставляем только целые числа в форатировании, запятые в мОмах лишние
    ActiveCell.Offset(-8, 0).Range("A1:A9").Select  ' поднимаемся в начало данных второй стороны платы
    ActiveCell.Range("A1:A9").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveSheet.Paste                                                'копируем на 2 ячейки вправо данные 2-й стороны платы
    ActiveCell.Offset(0, -2).Range("A1:A9").Select 
    Selection.ClearContents                                        ' очищаем диапазон
    'Selection.Cut Destination:=ActiveCell.Offset(0, 2).Range("A1:A9") 'переносим на 2 ячейки вправо весь выбранный столбец
    'ActiveCell.Offset(0, 2).Range("A1:A9").Select
End Sub

@АЕ · 03.05.2023, 16:30

Rechnick, я понял. Вам интересны тоько ваши решения, записанные макрорекордером. Продолжайте править.

@Rechnick · 04.05.2023, 09:26 **[ТС]**

Я, как вы видете, не "на ты" с кодом. Даже в полученном с помощью макрорекордера коде пишу комментарии, чтобы потом не гадать что и откуда взялось. Тем не менее, мой вариант работает, косо, криво, но работает. Начал разбираться в вашем коде - появилось немало вопросов. Для меня ваш код - первый код на VBA, в котором надо разобраться. Хотя я узнал про VB 20 лет назад, но им никогда не занимался, как впрочем и программированием. Хотя почти 7 лет считался "программистом", так бывает.

@АЕ · 04.05.2023, 10:14

Rechnick, если вставлять данные из буфера обмена в столбец, на котором активна (выделена) любая ячейка, то код может иметь такой вид. Это самое простое решение под хотелку продолжения заполнения вправо.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Public Sub ttt()
    Dim s As String, d, x
    s = Clipboard_GetText()
    d = Text2Array(s)
    PS = ActiveCell.Column
    For i = LBound(d, 1) To UBound(d, 1) ' row
        For j = LBound(d, 2) To UBound(d, 2) ' col
            Select Case j
            Case 3
                If i < 10 Then x = PS Else x = PS + 2
                If i = 1 Or i = 10 Then
                    Cells(i + 2, x) = 100000
                Else
                    If d(i, 4) = "MOhm" Then
                        Cells(i + 2, x) = Val(d(i, j)) * 1000
                    Else
                        Cells(i + 2, x) = Val(d(i, j))
                    End If
                End If
            End Select
        Next j
    Next i
End Sub

Новые блоги и статьи Все статьи Все блоги /
Локальный http сервер Argus19 17.10.2026 Локальный http сервер На работе, на двух локальных компьютерах круглосуточно работают программы опроса приборов с записью в книги Excel,которые раз в сутки записываются на сервер компании. Т. к. . . .	Копировать Windows на новый диск на UEFI damix 17.10.2026 https:/ / uriesk. wordpress. com/ 2016/ 11/ 01/ move-window-10-to-ssd-on-a-uefi-dualboot-system-with-basic-linux-tools/ TL DR Вставляем диск, а старый подключаем через переходник, грузимся с лайва. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .
Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .

@Rechnick 0 / 0 / 0 Регистрация: 19.04.2023 Сообщений: 16
	03.05.2023, 12:24 [ТС]
	Да, всегда две группы по 9 измерений. Только данные вношу в таблицу, по горизонтали смещаясь вправо. Теперь хочу либо копировать вторую половину измерений, вместо переноса, так как тогда форматирование ломаю, либо потом границы дорисовывать. 0

@Rechnick 0 / 0 / 0 Регистрация: 19.04.2023 Сообщений: 16
	03.05.2023, 12:31 [ТС]
	Вот так заполняю таблицу, по мере измерений. Миниатюры 0

@АЕ ᴁ © 4088 / 2469 / 514 Регистрация: 13.12.2016 Сообщений: 8,397 Записей в блоге: 5
	03.05.2023, 16:30
	Rechnick, я понял. Вам интересны тоько ваши решения, записанные макрорекордером. Продолжайте править. 1

@Rechnick 0 / 0 / 0 Регистрация: 19.04.2023 Сообщений: 16
	04.05.2023, 09:26 [ТС]
	Я, как вы видете, не "на ты" с кодом. Даже в полученном с помощью макрорекордера коде пишу комментарии, чтобы потом не гадать что и откуда взялось. Тем не менее, мой вариант работает, косо, криво, но работает. Начал разбираться в вашем коде - появилось немало вопросов. Для меня ваш код - первый код на VBA, в котором надо разобраться. Хотя я узнал про VB 20 лет назад, но им никогда не занимался, как впрочем и программированием. Хотя почти 7 лет считался "программистом", так бывает. Изображения 0

Вставка в Excell данных мультиметра из буфера обмена

Решение