Страницы: 1
RSS
Сохранить диапазон в новый файл.
 
Добрый день.
Задача:
По нажатию кнопки сохранять диапазон листа со  значениями(только значений без формул) в новый файл.

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

Вот пример кода который делает почти как надо, но сохраняет всю область листа. Сюда бы добавить выбор диапазона.
Помогите.
Код
Private Sub CommandButton1_Click()
    Dim FileN$, wb As Workbook
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("B1") & ".xlsm"
    ThisWorkbook.SaveCopyAs FileN
    Set wb = Workbooks.Open(FileN)
    ActiveSheet.DrawingObjects.Delete    'óäàëåíèå âñåõ êíîïîê
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
    ActiveSheet.Copy
    wb.Close SaveChanges:=False
    Kill FileN
    Mid(FileN, Len(FileN), 1) = "x"
    ActiveWorkbook.SaveAs FileN, 51
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Òåêóùèé ëèñò ñîõðàíåí â íîâîé êíèãå" & FileN
End Sub 
 
Код
Private Sub CommandButton1_Click()
    RangeCopy Range("B3:D5")
End Sub

Private Sub CommandButton2_Click()
    RangeCopy Selection
End Sub

Private Sub RangeCopy(rn As Range)
    Dim FileN$, wb As Workbook
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("B1") & ".xlsm"
    
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)
        rn.Copy .Cells(1)
        If rn.Rows.Count = 1 And rn.Columns.Count Then
            .Value = .Value
        Else
            Dim arr As Variant
            arr = .Value
            .Value = arr
        End If
    End With
    
    On Error Resume Next
    Kill FileN
    On Error GoTo 0
    wb.SaveAs FileN, 52
    wb.Close False
    
'    ThisWorkbook.SaveCopyAs FileN
'    Set wb = Workbooks.Open(FileN)
'    ActiveSheet.DrawingObjects.Delete    'oaaeaiea anao eiiiie
'    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'    ActiveSheet.Copy
'    wb.Close SaveChanges:=False
'    Kill FileN
'    Mid(FileN, Len(FileN), 1) = "x"
'    ActiveWorkbook.SaveAs FileN, 51
'    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Oaeouee eeno nio?aiai a iiaie eieaa" & FileN
End Sub
 
этот
Код
Sub Range2NewFile()
  Dim rg As Range, a
  Set rg = Selection: a = rg
  Workbooks.Add:  Range(rg.Address) = a
End Sub

в стандартный модуль
в вашем файле отмечаете нужный диапазон, жмете Alt+F8, в открывшемся окне найдите и выполните Range2NewFile
Изменено: Ігор Гончаренко - 20.05.2022 14:26:13
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, там ещё форматы ячеек нужны.
 
если нужно с форматами - скопируйте туда же и выполните  тем же способом Range2NewFile2
Код
Sub Range2NewFile2()
  Dim rg As Range
  Set rg = Selection: rg.Copy: Workbooks.Add
  Range(rg.Cells(1).Address).PasteSpecial Paste:=xlPasteValues
  Range(rg.Cells(1).Address).PasteSpecial Paste:=xlPasteFormats
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
написал:
Код
    [URL=#]?[/URL]       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      Private   Sub   CommandButton1_Click()          RangeCopy Range(  "B3:D5"  )    End   Sub       Private   Sub   CommandButton2_Click()          RangeCopy Selection    End   Sub       Private   Sub   RangeCopy(rn   As   Range)          Dim   FileN$, wb   As   Workbook          FileN = ThisWorkbook.Path &   "\" & "  Test_  " & Range("  B1  ") & "  .xlsm"                   Set   wb = Workbooks.Add(1)          With   wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)              rn.Copy .Cells(1)              If   rn.Rows.Count = 1   And   rn.Columns.Count   Then                  .Value = .Value              Else                  Dim   arr   As   Variant                  arr = .Value                  .Value = arr              End   If          End   With                   On   Error   Resume   Next          Kill FileN          On   Error   GoTo   0          wb.SaveAs FileN, 52          wb.Close   False             '    ThisWorkbook.SaveCopyAs FileN    '    Set wb = Workbooks.Open(FileN)    '    ActiveSheet.DrawingObjects.Delete    'oaaeaiea anao eiiiie    '    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value    '    ActiveSheet.Copy    '    wb.Close SaveChanges:=False    '    Kill FileN    '    Mid(FileN, Len(FileN), 1) = "x"    '    ActiveWorkbook.SaveAs FileN, 51    '    ActiveWorkbook.Close SaveChanges:=False          MsgBox   "Oaeouee eeno nio?aiai a iiaie eieaa"   & FileN    End   Sub   
 
Код
Private Sub CommandButton1_Click()
    RangeCopy Range("B3:D5")
End Sub
 
Private Sub CommandButton2_Click()
    RangeCopy Selection
End Sub
 
Private Sub RangeCopy(rn As Range)
    Dim FileN$, wb As Workbook
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("B1") & ".xlsm"
     
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)
        rn.Copy .Cells(1)
        If rn.Rows.Count = 1 And rn.Columns.Count Then
            .Value = .Value
        Else
            Dim arr As Variant
            arr = .Value
            .Value = arr
        End If
    End With
     
    On Error Resume Next
    Kill FileN
    On Error GoTo 0
    wb.SaveAs FileN, 52
    wb.Close False
     
'    ThisWorkbook.SaveCopyAs FileN
'    Set wb = Workbooks.Open(FileN)
'    ActiveSheet.DrawingObjects.Delete    'oaaeaiea anao eiiiie
'    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'    ActiveSheet.Copy
'    wb.Close SaveChanges:=False
'    Kill FileN
'    Mid(FileN, Len(FileN), 1) = "x"
'    ActiveWorkbook.SaveAs FileN, 51
'    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Oaeouee eeno nio?aiai a iiaie eieaa" & FileN
End Sub

Добрый день. Данный код работает если формулы и исходные данные находятся в диапазоне сохранения, но если для вычисления формулы используются данные за пределами диапазона то ячейка при сохранение пуста. Вы уж извините я не силен в VBA и поиски решения в интернете этой задачи пока положительных результатов не дали. Я уже подумываю создать скрытый лист в файле, скопировать нужные данные сперва туда, а потом сохранять. Почему все так заморочно...
Изменено: Михаио z - 21.05.2022 16:52:27
 
Цитата
написал:
если нужно с форматами - скопируйте туда же и выполните  тем же способом Range2NewFile
Не понял?
Изменено: Михаио z - 21.05.2022 12:35:33
 
цитата не полная:
Цитата
Ігор Гончаренко написал:
если нужно с форматами - скопируйте туда же и выполните  тем же способом Range2NewFile2
между выполнить Range2NewFile и Range2NewFile2 большая разница
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
До сих пор проблему не решил.

Предложенный код работает частично.
1. Не сохраняет ширину столбцов
2. Если исходные данные для формулы находятся вне диапазона то значения отсутствуют (ячейка пуста).

Пример прикрепил.
 
Код
Private Sub CommandButton1_Click()
    RangeCopy Range("A1:D16")
End Sub

Private Sub RangeCopy(rn As Range)
    Dim FileN$, wb As Workbook
    
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("A1") & ".xlsm"
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)
        rn.Copy .Cells(1)
        If rn.Rows.Count = 1 And rn.Columns.Count Then
            .Value = .Value
        Else
            Dim arr As Variant
            arr = .Value
            .Value = arr
        End If
    End With
    
    rn.Copy
    wb.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
    wb.Sheets(1).Cells(1, 1).Select
    On Error Resume Next
    Kill FileN
    On Error GoTo 0
    wb.SaveAs FileN, 52
    wb.Close False
    MsgBox "ОК & FileN"
End Sub
 
Срасибо!
Осталось одна проблема.

Если исходные данные для формулы находятся вне диапазона то значения отсутствуют (ячейка пуста).
 
Код
Private Sub CommandButton1_Click()
    RangeCopy Range("A1:D16")
End Sub
 
Private Sub RangeCopy(rn As Range)
    Dim FileN$, wb As Workbook
     
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("A1") & ".xlsm"
    Set wb = Workbooks.Add(1)
    
    Dim arr As Variant
    If rn.Rows.Count = 1 And rn.Columns.Count Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rn.Value
    Else
        arr = rn.Value
    End If
    
    With wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)
        rn.Copy .Cells(1)
        .Value = arr
    End With
     
    rn.Copy
    wb.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
    wb.Sheets(1).Cells(1, 1).Select
    On Error Resume Next
    Kill FileN
    On Error GoTo 0
    wb.SaveAs FileN, 52
    wb.Close False
    MsgBox "ОК & FileN"
End Sub
 
Спасибо проблема решена!!!!
Изменено: Михаио z - 30.05.2022 10:11:35
 
Цитата
Михаио z написал:
Предложенный код работает частично
любые коды будут работать настолько частично, насколько частично описана задача
Цитата
Михаио z написал:
Как победить эту проблему
вы рассказываете как вы представляете победу над проблемой, вам рассказывают, показывают как это сделать
а пока каждый будет побеждать то, что ему вздумается, ваша реальная задача может оказаться так и не решенной
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Страницы: 1
Наверх