Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

Макрос копирования данных из ячеек в таблицу

Автор Mailo, 17.09.2011, 22:53

« назад - далее »

Mailo

Здравствуйте. Помогите, пожалуйста, с написанием макроса. Нужен макрос, который копировал бы данный из некоторой ячейки листа sf в строку таблицы(лист «учет»).Макрос надо что бы запускался при нажатии кнопки «учет» на листе sf. Например что бы при нажатии на кнопку данные из ячейки sf!I28 копировались бы в первый пустой столбец Е таблицы, находящейся на листе УЧЕТ. Причем данные должны копироваться не в формулой а текстовым значением.
Книга прилагается.   
Спасибо

Wasilic

ЦитироватьSub УЧЕТ()
  Dim SZ As Integer
  SZ = Sheets("Учет").Range("E" & Cells.Rows.Count).End(xlUp).Row + 1
  Sheets("Учет").Cells(SZ, 5) = Range("I28")
  MsgBox " Г О Т О В О !"
End Sub
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

Mailo

Спасибо, Wasilic
Получилось. Я только немного подправил файл.
  Dim SZ As Integer
  SZ = Sheets("Журнал_рег").Range("e" & Cells.Rows.Count).End(xlUp).Row + 1
  Sheets("Журнал_рег").Cells(SZ, 5) = Range("sf!I28")
  Sheets("Журнал_рег").Cells(SZ, 4) = Range("sf!g5")
  Sheets("Журнал_рег").Cells(SZ, 1) = Range("sf!g4")
  Sheets("Журнал_рег").Cells(SZ, 2) = Range("sf!d11")
  Sheets("Журнал_рег").Cells(SZ, 3) = Range("sf!a25")

Копирование ячеек происходит при нажатии кнопки «сохранить».Так же при нажатии кнопки «сохранить» копируются 2 первых листа в отдельный файл. То есть копируется счет-фактура и акт в папку /saves.
Так вот у меня появилась еще одна задача. Нада что бы при нажатии нажатии на кнопку «сохранить» на страницу «журнал рег» в столбец D (документ) добавлялась ссылка на сохраненный файл.
Надеюсь ясно выразился. Качайте документ и думаю задача станет яснее) Вод исправленная версия исходного файла.
Спасибо.
PS: Не корректно почему-то копируются данные из ячейки с датой.
Т.е   Sheets("Журнал_рег").Cells(SZ, 4) = Range("sf!g5")

Wasilic

Здравствуйте.
В столбце D установите формат даты.
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

Mailo

Цитата: Wasilic от 20.09.2011, 10:20
Здравствуйте.
В столбце D установите формат даты.
Спасибо. А может подскажете, что дописать в массиве что бы данные не только копировались,но в одном столбце (I) протягивалась формула =СУММЕСЛИ(B$4:B4;B4;H$4:H4)-СУММЕСЛИ(B$4:B4;B4;E$4:E4) ?Ну и таблица что бы продолжалась. То есть ячеки были разленеены так же как и выше, то есть имели границы.

Wasilic

Здравствуйте.
Допишите в макрос:
Sheets("Журнал_рег").Select
  Range("A" & SZ & ":J" & SZ).Select
  Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
  Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
  Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
  Range("I" & SZ - 1).Select
  Selection.Copy
  Range("I" & SZ).Select
  ActiveSheet.Paste
  Application.CutCopyMode = False
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

Mailo

#6
Спасибо,Wasilic . Есть еще просьба!)
вот макрос:
Private Sub My_MkDir(iPath$)
   iStart& = 1    '3
   iPathSeparator$ = Application.PathSeparator    '"\"
   iPath$ = iPath$ & _
            IIf(Right(iPath$, 1) = iPathSeparator$, "", iPathSeparator$)
   Do
       iStart& = InStr(iStart& + 1, iPath$, iPathSeparator$)
       iTempPath$ = Mid(iPath$, 1, iStart&)
       If Dir(iTempPath$, vbDirectory) = "" Then _
          MkDir iTempPath$
   Loop While iStart& <> 0
End Sub

Sub Divide_Workbook()
   Dim WbMain As Workbook
   Dim Wb As Workbook
   Dim sh As Worksheet
   Dim DateString As String
   Dim FolderName As String

   Application.ScreenUpdating = False
   Application.EnableEvents = False

   DateString = Format(Now, "dd-mm-yy")
   Set WbMain = ActiveWorkbook

   FolderName = WbMain.Path & "\saves"
   My_MkDir FolderName
   Worksheets(Array("sf", "akt")).Copy
   Set Wb = ActiveWorkbook
   Dim oVBComponent As Object
   For Each sh In Wb.Sheets
       sh.UsedRange.Value = sh.UsedRange.Value
       sh.DrawingObjects.Delete
   Next
   Wb.Sheets("sf").Range("C29,L29").Value = Сумма_прописью([I28])
   For Each oVBComponent In Wb.VBProject.VBComponents
           oVBComponent.CodeModule.DeleteLines 1, oVBComponent.CodeModule.CountOfLines
   Next

   Wb.SaveAs FolderName & "SF_№_" & Worksheets("sf").Range("sf!g4") & "_ot_" & DateString & ".xls"
   MsgBox "Счет-фактура сохранена"
   Wb.Close False


   Application.ScreenUpdating = True
   Application.EnableEvents = True
 'копирование данных в журнал регестрации
 Dim SZ As Integer
 SZ = Sheets("Журнал_рег").Range("e" & Cells.Rows.Count).End(xlUp).Row + 1
 Sheets("Журнал_рег").Cells(SZ, 5) = Range("sf!I28")
 Sheets("Журнал_рег").Cells(SZ, 4) = Range("sf!g5")
 Sheets("Журнал_рег").Cells(SZ, 1) = Range("sf!g4")
 Sheets("Журнал_рег").Cells(SZ, 2) = Range("sf!d11")
 Sheets("Журнал_рег").Cells(SZ, 3) = Range("sf!a25")
 Sheets("Журнал_рег").Select
 Range("A" & SZ & ":J" & SZ).Select
 Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
 Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
 Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
 Range("I" & SZ - 1).Select
 Selection.Copy
 Range("I" & SZ).Select
 ActiveSheet.Paste
   Range("k" & SZ - 1).Select
 Selection.Copy
 Range("k" & SZ).Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
End Sub


этот макрос запускается при нажатии кнопки сохранить. Я жму на кнопку и 2 листа Akt и SF сохраняются отдельным файлом в папку FolderName = WbMain.Path & "\saves" . А так же происходит копирование определенных  ячеек в таблицу(эту часть макроса вы мне написали) Вот хотелось бы, что бы при нажатии на кнопку сохранить в нашу таблицу в столбец J добавлялась и ссылка на ранее сохраненный файл. Надеюсь понятно объяснил))

Wasilic

#7
Ну так есть же в макросе строка сохранения файла:
Wb.SaveAs FolderName & "SF_№_" & Worksheets("sf").Range("sf!g4") & "_ot_"& DateString & ".xls"
так запишите ее и в столбец 10 (J)
Sheets("Журнал_рег").Cells(SZ, 10) = FolderName & "SF_№_" & Worksheets("sf").Range("sf!g4") & "_ot_"& DateString & ".xls"

PS: Не проверял!
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

Mailo

я не уточнил.Должна быть не просто ссылка, а гиперссылка на файл)

Wasilic

Мне не приходилось делать гиперссылки макросом,
поищите здесь:
http://msoffice.nm.ru/faq/macros.htm
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.