Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование данных с одного листа на другой
 
#1
04.02.2026 16:07:38
Добрый вечер! Помогите пожалуйста доработать макрос копирования. Столкнулся с проблемой,если на чистый лист, всё копируется как надо, а в форме объединённые ячейки
 
 
 
#2
04.02.2026 16:10:52
Тема была создана на http://www.excelworld.ru/forum/10-55200-1
 
 
 
#3
04.02.2026 16:35:01
Код
Sub tt()
    Sheets("ОДНОСТРОЧНЫЙ").Select
    Range("H13:AL27").Select
    With Selection
        shIn_ = .Parent.Index
        ad_ = .Address
        nr_ = .Rows.Count
        .copy
    End With
    Dim awb As Workbook
    Set awb = ActiveWorkbook
    
    With Workbooks.Add(1).Sheets(1)
        Application.ScreenUpdating = 0
        With .Range(ad_)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            For i = nr_ - 1 To 1 Step -1
                .Offset(i).Resize(1).EntireRow.Insert
            Next i
            .Offset(1, 16).Resize(1, 1).EntireColumn.Insert
            .Offset(, 17).Resize(nr_ * 2 - 1, 15).copy
            .Offset(1, 1).Resize(1, 1).Select
        End With
        .PasteSpecial Format:=1, Link:=1, DisplayAsIcon:=True, IconFileName:=False
        .Range(ad_).Offset(, 16).Resize(nr_ * 2 - 1, 16).Clear
        
        With .Range(ad_).Offset(, 0).Resize(nr_ * 2 - 1, 16)
            .copy
            awb.Sheets("СУДОВОЙ").Range(.Address).PasteSpecial Paste:=xlPasteValues
            awb.Sheets("СУДОВОЙ").Range(.Address).PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End With
        Application.ScreenUpdating = 1
        .Parent.Close False
    End With
    awb.Activate
    Calculate
    Sheets("ОДНОСТРОЧНЫЙ").Select
    Range("H13").Select
End Sub
Когда прокачаете навык VBA, увидите, что можно не использовать .Select. Но пока можно и с ним.
 
 
 
#4
04.02.2026 16:46:53
GGE29, Что же Вы не сообщаете о КРОССах, согласно Правилам форума
 
 
 
#5
04.02.2026 16:52:34
Вариант без .Select.
Код
Sub tt()
    Dim rSource As Range
    Set rSource = Sheets("ОДНОСТРОЧНЫЙ").Range("H13:AL27")
    With rSource
        Dim ad_ As String
        ad_ = .Address
        Dim nr_ As Long
        nr_ = .Rows.Count
    End With
    
    Dim rTarget As Range
    Set rTarget = Sheets("СУДОВОЙ").Range(ad_).Cells(1, 1)
    
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim ys As Long, xs As Long, yt As Long, xw As Long
    For ys = 1 To rSource.Rows.Count
        xw = 16 + 1
        For xs = 1 To rSource.Columns.Count Step 16
            yt = yt + 1
            xw = xw - 1
            rSource.Cells(ys, xs).Resize(1, xw).Copy
            rTarget(yt, 1).PasteSpecial Paste:=xlPasteValues
            rTarget(yt, 1).PasteSpecial Paste:=xlPasteFormats
        Next
    Next
    Calculate
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub
 
 
 
#6
04.02.2026 16:56:32
Последняя строка потерялась🤔
 
 
 
#7
04.02.2026 17:49:50
Цитата
написал:
Последняя строка потерялась
В варианте #5. не теряется.
 
 
 
#8
04.02.2026 18:38:26
Цитата
написал:
В варианте  #5.  не теряется.
Спасибо!Завтра на оригинале проверю и отпишусь
 
 
 
#9
05.02.2026 09:22:54
GGE29, Скажите а для чего Вы публикуете решение из этого форума в другой, Вы хоть пишите кто написал это решение, кстати _Boroda_, тут тоже присутствует
Изменено: Msi2102 - 05.02.2026 09:31:58
 
 
 
#10
05.02.2026 09:46:39
Добрый день!Снова проблема 16 число не корректно переносится на другую строку,а точнее пропадает
 
 
 
#11
05.02.2026 10:09:39
Код
Sub tt()
    Dim rSource As Range
    Set rSource = Sheets("ОДНОСТРОЧНЫЙ").Range("H13:AL27")
    With rSource
        Dim ad_ As String
        ad_ = .Address
        Dim nr_ As Long
        nr_ = .Rows.Count
    End With
     
    Dim rTarget As Range
    Set rTarget = Sheets("СУДОВОЙ").Range(ad_).Cells(1, 1)
     
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim ys As Long, xs As Long, yt As Long, xw As Long, vv As Variant
    For ys = 1 To rSource.Rows.Count
        For Each vv In Array(Array(1, 15, True), Array(16, 16, False))
            yt = yt + 1
            xs = vv(0)
            xw = vv(1)
            If vv(2) Then rTarget(yt, xw + 1).Clear
            rSource.Cells(ys, xs).Resize(1, xw).Copy
            rTarget(yt, 1).PasteSpecial Paste:=xlPasteValues
            rTarget(yt, 1).PasteSpecial Paste:=xlPasteFormats
        Next
    Next
    Calculate
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub
Изменено: МатросНаЗебре - 05.02.2026 10:09:57
 
 
 
#12
05.02.2026 16:59:00
Код
Sub tt()
    Dim rSource As Range
    Set rSource = Sheets("ОДНОСТРОЧНЫЙ").Range("H13:AL27")
    With rSource
        Dim ad_ As String
        ad_ = .Address
        Dim nr_ As Long
        nr_ = .Rows.Count
    End With
     
    Dim rTarget As Range
    Set rTarget = Sheets("СУДОВОЙ").Range(ad_).Cells(1, 1)
     
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
     
    Dim ys As Long, xs As Long, yt As Long, xw As Long, vv As Variant
    For ys = 1 To rSource.Rows.Count
        CopyRange 1, 15, True, ys, rSource, yt, rTarget
        CopyRange 16, 16, False, ys, rSource, yt, rTarget
    Next
    Calculate
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

Private Sub CopyRange(xs As Long, xw As Long, needClear As Boolean, ys As Long, rSource As Range, yt As Long, rTarget As Range)
    yt = yt + 1
    If needClear Then
        rTarget(yt, xw + 1).Clear
        With rTarget(yt, xw + 1).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End If
    rSource.Cells(ys, xs).Resize(1, xw).Copy
    rTarget(yt, 1).PasteSpecial Paste:=xlPasteValues
    rTarget(yt, 1).PasteSpecial Paste:=xlPasteFormats
End Sub
Поправил границы в правой ячейке.
 
 
 
#13
05.02.2026 19:40:18
А я заменил For Each vv In Array(Array(1, 15, True на False и всё норм. Но всё равно огромное спасибо Вам за помощь
 
 
 
#14
06.02.2026 11:02:31
Цитата
написал:
А я заменил For Each vv In Array(Array(1, 15, True на False и всё норм.
... до тех пор, пока в этой ячейке не появятся старые значения.
Ну да ладно, что эти программисты понимают! :D  
 
 
 
#15
06.02.2026 12:55:47
Цитата
написал:
Ну да ладно, что эти программисты понимают!
Главное — чтобы компьютер не догадался, что они не понимают, как это работает."😜
Изменено: asesja - 06.02.2026 12:58:57
 
 
 
Страницы: 1
Читают тему
Наверх