Недавно я взял с вашего форума классный скрипт, который фильтрует один файл по колонке и на основе фильтрации создает несколько файлов и сохраняет их. Как к этому скрипту добавить чтобы он в каждый файл вставлял первую строчку с основного файла в каждый следующий (отфильтрованный файл)
Код
Option Explicit
Sub copyu()
Dim oDic As Object, oFSO As Object
Dim arrData(), arrSeparateItems(), arrTemp()
Dim TempWb As Workbook
Dim sFolderPath As String, sFullFileName As String
Dim LastRow As Long, i As Long, n As Long, c As Long, r As Long
If MsgBox(?????", vbQuestion + vbYesNo, "Разбивка") = vbNo Then Exit Sub
sFolderPath = "https://mhpo365.sharepoint.com"
If sFolderPath = vbNullString Then Exit Sub
If Right(sFolderPath, 1) <> Application.PathSeparator Then sFolderPath = sFolderPath & Application.PathSeparator
Application.ScreenUpdating = False
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDic = CreateObject("Scripting.Dictionary")
With ActiveSheet
If .FilterMode = True Then .ShowAllData
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range("A2:AB" & LastRow).Value
End With
For i = 1 To UBound(arrData)
If Not oDic.Exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), 0&
Next i
arrSeparateItems() = oDic.Keys
For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)
ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
r = 0
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) = arrSeparateItems(n) Then
r = r + 1
For c = LBound(arrData, 2) To UBound(arrData, 2)
arrTemp(r, c) = arrData(i, c)
Next c
End If
Next i
Set TempWb = Workbooks.Add
With TempWb.Worksheets(1)
.Range("A1").Resize(1, UBound(arrData, 2)).Value = arrData
.Range("A2").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
.Columns("A:Z").AutoFit
End With
sFullFileName = sFolderPath & arrSeparateItems(n) & ".xlsx"
If oFSO.FileExists(sFullFileName) Then oFSO.Deletefile (sFullFileName)
TempWb.SaveAs sFullFileName, FileFormat:=51 'XLSX
TempWb.Close SaveChanges:=False
Next n
Application.ScreenUpdating = True
MsgBox "???? " & sFolderPath, vbInformation
End Sub
yurisl,Привет, тебе не нужны формулы, это csv файл! А комы там это разделители, нажми на кнопку "текст по столбцам" и раздели с разделителем кома. Вот и все)
У некоторых пользователей возникла ошибка: (run time error -2147467259 (80004005)) не удаеться сохранить ярлык. Можете подсказать в чем ошибка? Код макроса:
Код
Private Sub Workbook_Open()
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
Dim strDesktop As String
strDesktop = WshShell.SpecialFolders("Desktop")
Dim oShellLink As Object
Set oShellLink = WshShell.CreateShortcut(strDesktop & "\A.I.D.A.lnk")
oShellLink.TargetPath = "https://apps.powerapps.com/"
oShellLink.WindowStyle = 1
oShellLink.IconLocation = "G:\"
oShellLink.Description = "The best app in the world"
oShellLink.WorkingDirectory = strDesktop
oShellLink.Save
Dim a As Integer
a = MsgBox("Поздравляю, на вашем рабочем столе появился значек A.I.D.A" & vbNewLine & "Приятного использования!", 64)
UserForm1.Show
End Sub
Помогите с задачей: Приходит письмо с картинкой формата .ico и ексель файл, в ескселе макрос который скопирует картинку из вложения и вставит на рабочий стол. Мне в голову ничего не приходит( Жду вашей помощи!
Sub CreateDesktopShortcutWithIcon()
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
Dim strDesktop As String
strDesktop = WshShell.SpecialFolders("Desktop")
Dim oShellLink As Object
Set oShellLink = WshShell.CreateShortcut(strDesktop & "\название.lnk")
oShellLink.TargetPath = "ссылка"
oShellLink.WindowStyle = 1
oShellLink.IconLocation = "C:\__tmp\MIME\foo.ico" '
oShellLink.Description = "THE BEST OF THE BEST"
oShellLink.WorkingDirectory = strDesktop
oShellLink.Save
End Sub
Сможете подсказать где тут ссылка на картинку файла, так же можете подскажете как подставить туда свою картинку! Буду очень благодарен!
Может кто-то знает или может помочь как мне создать ярлык на рабочем столе с ссылкой внутри и с правильной картинкой с помощью VBA. Создаеться для удобства пользователя! Картинка ярлыка должна меняться на нужную, в данном примере можно использовать лубую! Ссылка должна быть на гугл форму но для удобства можно встасить ссылку на этот форум (https://www.planetaexcel.ru/forum/)
Добрый день, Столкнулся с проблемой, не могу придумать как убать из total в матрице одну колонку, что-бы тотал по ней не считался! Помогите с проблемой)