Някой на "ти" с Ексел?

[bum_bum]

Имам една задачка, която трябва да изпълнявам периодично и се чудя дали може да се автоматизира. Търсих в разни форуми, но не намирам нищо подобно. Предполагам ще трябва да се създаде макрос, който да я изпълни.

Имам файл с 3-4000 записа като в колона А имам 3 или 4 буквено съкращение. Това, което трябва да направя е да създам толкова различни нови документа, колкото различни стойности имам в колона А. Във всеки файл съдържанието трябва да е всичко, което се вижда като филтрирам по съответната стойност в тази колона.

Някой има ли идея как да стане?

[kener Профил]

Дай някакъв пример(няколко реда) за да може да стане ясно какво точно искаш да стане. Най-малкото може да се пробват варианти.

Иначе си е мазохизъм да работиш с толкова данни с ексел. Задачката звучи, като курсова работа за програмисти. Една база данни, едно приложение на С шарп, да чете и пише в базата, и да прави, каквото ти трява. Трябва ти някои колега, който е правил нещо в тази насока и да ти едитне прокта си по твое задание.

[Cyberloner Профил]

Отделяш си няколко часа от живота(ако предположим, че нямаш предишен опит с програмиране, но си ОК с английския), за да си направиш едно macro и няма къде да ходи че да не стане

[bum_bum]

Както съм го обяснил и аз трудно схващам какво искам. Примерно от този фаил трябва да направя два нови файла с имена REA и SMA, които да съдържат информацията в колоните от А до Г съответно за REA и SMA. Изгубих цял ден да се опитвам да направя макрос, който да го върши, но нещо не ми се получава.

https://www.dropbox.com/s/ek12l0ndeqkv6 ... .xlsx?dl=0

[Cyberloner Профил]

ето едно макро спретнато набързо

Sub Macro1()
'
' Macro1 Macro
'

'
Columns("A:G").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$G$174").AutoFilter Field:=1, Criteria1:="SMA"
Rows("1:174").Select
Selection.Copy
Workbooks.Add
Rows("1:1").Select
ActiveSheet.Paste
Windows("Example-1.xlsx").Activate
ActiveSheet.Range("$A$1:$G$174").AutoFilter Field:=1, Criteria1:="REA"
Rows("1:153").Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Windows("Book1").Activate
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
ChDir "C:\Users\Despotov\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\Despotov\Desktop\SMA.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Windows("Book2").Activate
Range("A3").Select
ActiveCell.FormulaR1C1 = "REA"
Range("G6").Select
ActiveWorkbook.SaveAs Filename:="C:\Users\Despotov\Desktop\REA.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
ActiveWindow.Close
End Sub

Само си оправи пътищата до това къде да ти запази нещата и пробвай дали прави това, което ти се иска.

иначе това прави следното:
1. прави филтър
2. избира да се покаже дадена стойност
3. избира всички клетки и ги вкарва в clipboard-a
4. прави нов файл
5. взима клетките от clipboard-a и ги слага в новия файл
6. прави същото със следващата стойност от филтъра
7. запазва и двата файла


Това е много набързо и предполага, че имаш малко стойности като разнообразие и че се повтарят всеки път. Ако са вече 20-50-100 и нагоре стойности ще трябва да се направи едно цикълче да върти през филтъра и да взима стойността на клетка А2 за име на файла преди разширението, когато го запазва. Ако имам време мога да ти го направя, но не мога да обещая нищо...

[bum_bum]

Пробвах го, но ми дава Subscript out of range на Windows("Book1").Activate.

В оригиналния файл в който работя стойностите са около 100.

Горе-долу схванах как трябва да изглежда макроса. Ще се мъча да чета още, дано вдена нещо Мерси

[Cyberloner Профил]

разрових малко и намерих нещо, което е близо да твоят случай, само че вместо нови файлове прави нови листове, което лесно се коригира.

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names for worksheets)
Set rngStart = Worksheets("Sheet1").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet1").Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with names
For Each rngCell In Range(rngStart, rngEnd)
'get name
strWsName = rngCell.Text
'exclude the main inelligible names
If strWsName <> "" And InStr(1, strWsName, "/") = 0 _
And InStr(1, strWsName, "\") = 0 And InStr(1, strWsName, "?") = 0 _
And InStr(1, strWsName, "*") = 0 And InStr(1, strWsName, "[") = 0 _
And InStr(1, strWsName, "]") = 0 Then
'test if worksheet exists
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy row to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp).Offset(1, 0)
rngCell.EntireRow.Copy
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Else
'name not valid - warn user - but ignore empty cells
If strWsName <> "" Then
MsgBox strWsName & " is not a valid worksheet name", vbOKOnly, _
"Worksheet Names"
End If
End If
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

писано е на .net като гледам, така че лесно ще го адаптираш към ексела.
Ето и линк към форума, от който го взех http://www.computing.net/answers/office ... 10544.html

[bum_bum]

Твоето го подкарах и ги направи. Неудобството там е, че трябва да напиша всичките имена на файлове. Сега ще опитам и с това другото.

[Cyberloner Профил]

е да де затова ти казах, че трябва да и направиш цикълче, което да върти през филтъра.
След това, като копира клетките в новия workbook, да чете стойността от клетка А2 и да я ползва за име на файла, когато го запазва.

[bum_bum]

Този другия работи добре. Направи ми един документ с 54 страници, колкото са ми стойностите в А в документа. Може би ще е по-лесно да го правя така и после да си разделя всяка страница в нов документ. Намерих това за да го направи:

Код: Избери целия код

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Обаче, не мога да си създам директория на десктопа в която да ми сложи новите файлове. Пиша MkDir Macintosh HD:Users:Ivo:Desktop:KAU, обаче като го стартирам ми дава "Expected end of statement" и ми маркира HD..

[Cyberloner Профил]

Mac? хмм

не съм убеден ама мисля, че трябва да сложиш това в скоби и да стане нещо като MkDir (Macintosh HD:Users:Ivo:Desktop:KAU)

[© Профил ICQ]

Гледам, че темата върви много добре. Моля не я закривайте като решите проблема, че искам да попитам за нещо далеч по-дребно

[bum_bum]

Не съм съвсем сигурен, че трябва да пиша път тук. Оригинално в кода, който копирам е така- MkDir FolderName

Като стартирам макроса ми дава грешка там. Опитвах да напиша път до десктопа с новата директория, но не иска. Слагах и скоби и черти вместо точките, но не става .. после го изтрих направо този ред и тръгна. Сложи всички файлове в Macintosh HD и ми дава това съобщение.


Самият файл пък го именува така: Desktop\KAU-11-ALL-1.xlsx 2014-11-09 23-00-01\AFI

Не може обаче да се отвори файла, явно като греши директорията нещо ги поврежда.

[Cyberloner Профил]

не съм запознат с идеите на Мас.... там как са организирани нещата - декстопа е в root-a или е като при windows - поддиректория на директорията за потребителя? аз като си правя разни експерименти такива си правя винаги нещата да са в някаква елементарна пака от сорта на C:\test\ и да знам че от path-a поне няма начин да имам проблем

[bum_bum]

Направих го с друг код. Option Explicit

Код: Избери целия код

Sub SaveShtsAsBook()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         '      End With
        On Error Resume Next '<< a folder exists
        MkDir MyFilePath '<< create a folder
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                 'save book in this folder
                .SaveAs Filename:=MyFilePath _
                & "\" & SheetName & ".xls"
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sheet1.Activate
End Sub

Пак ми ги сложи там, но вече могат да се отварят. Като цяло се получиха нещата. Ще търся как да се доизпипа, но и така да остане пак ми върши чудесна работа.

В този първия код, който разделя нещата в отделни страници не мога да разбера как да го направя всяка нова страница да започва с това, което е на А1 и после отдолу да слага останалите неща. За сега ще ги слагам на ръка и по-натам ще опитам и това да оправя.