Dim str2 As String

Do
str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
If str2 = "False" Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена выполнения операции!", vbCritical, "Информационное сообщение"
Exit Sub
End If
If str2 <> "" Then Exit Do
MsgBox "Необходимо ввести наименование столбца!", vbCritical, "Информационное сообщение"
Loop

On Error Resume Next
Set r3 = Application.InputBox(Prompt:="Диапазон:", Title:="Выберете диапазон ячеек", Type:=8)
If r3 Is Nothing Then 'нажата кнопка "Отмена"
MsgBox "Отмена выполнения операции!", vbCritical, "Информационное сообщение"
Exit Sub 'завершаем процедуру, т.к. ячейки не выбраны
End If

ReDim strarr(QC)
For i = 1 To QC
Do
strarr(i) = Application.InputBox(Prompt:="наименование столбца " & CStr(i), Title:="Укажите...", Type:=2)
If strarr(i) = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена выполнения операции!", vbCritical, "Информационное сообщение"
Exit Sub
End If
If strarr(i) <> "" Then Exit Do
MsgBox "Необходимо ввести наименование столбца!", vbCritical, "Информационное сообщение"
Loop

Dim str2 As String

Do
str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
If str2 = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена выполнения операции!", vbCritical, "Информационное сообщение"
Exit Sub
End If
If str2 <> "" Then Exit Do
MsgBox "Необходимо ввести наименование столбца!", vbCritical, "Информационное сообщение"
Loop

str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
If str2 = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
Exit Sub
End If

Sub ConvertData()

Dim FName As Variant
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim z As Long
Dim N As Integer
Dim Hold As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim ColNum As Integer
Dim i As Long
Dim k As Long
Dim j As Long
Dim l As Long
Dim str As String
Dim str2 As String
Dim QC As Integer

FName = Application.GetOpenFilename(FileFilter:="Excel Workbooks,*.xl*", Title:="Выберите файл, который надо открыть", MultiSelect:=False)
If FName <> False Then
Workbooks.Open Filename:=FName
End If

On Error GoTo Inform
Set r3 = Application.InputBox(Prompt:="Диапазон:", Title:="Выберете диапазон ячеек", Type:=8)
r3.Select

Set r = r3

Set r2 = Application.InputBox(Prompt:="ячейку, с которой необходимо начать преобразование:", Title:="Выберете...", Type:=8)

QC = Application.InputBox(Prompt:="количество столбцов:", Title:="Укажите...", Type:=1)
If QC = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
Exit Sub
End If

ReDim strarr(QC)
For i = 1 To QC
strarr(i) = Application.InputBox(Prompt:="наименование столбца " & CStr(i), Title:="Укажите...", Type:=2)
If strarr(i) = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
Exit Sub
End If
Next i

str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
If str2 = False Then
'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
Exit Sub
End If


'..........
'..........
'Здесь идет код по преобразованию таблицы в нужный вид (не так важно уже)
'..........
'..........


Inform:
'Вывод информационного окна с сообщением об ошибке (при нажатии кнопки "Отмена")
MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
Exit Sub

End Sub

Sub запись()

Sheets("Лист1").[G1].ClearContents
    
    Sheets("Лист2").[D4].Copy
    Sheets("Лист1").Select
    
    Dim myFirstCell As Excel.Range
    Set myFirstCell = Sheets("Лист1").Rows(1).Find("*", LookIn:=xlValues, _
         LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
         MatchCase:=False, SearchFormat:=False)

    'Смотрим, была ли найдена хоть какая-то ячейка.
    'Если не найдена ячейка, т.е. вся вторая строка пустая
    '(если нет скрытых столбцов), то в переменной "myFirstCell" будет слово "Nothing".
    If Not myFirstCell Is Nothing Then

    myFirstCell.Offset(0, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    End If
    
    Sheets("Лист1").[G1].Select
    ActiveCell.FormulaR1C1 = "сумма"
        
End Sub

Sub запись()

    Application.ScreenUpdating = False
    
    Sheets("Лист2").[D4].Copy
    Sheets("Лист1").Select
        
    Cells(1).End(xlToRight).Offset(0, 1).PasteSpecial _
       Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
End Sub

Sub запись()

    Application.ScreenUpdating = False
    
    Sheets("Лист2").Select
    Range("D4").Select
    Selection.Copy
    
    Sheets("Лист1").Select
    
    Dim NextColumn As Long
    NextColumn = Range("A2:F2").End(xlToRight).Column + 1
    Cells(1, NextColumn).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub