Results 1 to 4 of 4

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Registered User
    Join Date: Aug:2005
    Location: Bugaria
    Posts: 652

    ïîìîù îòíîñíî EXCEL 2010

    Çäðàâåéòå,
    Èìà ëè âúçìîæíîñò äà íàïðàâÿ ñëåäíîòî íåùî?
    Èìàì åäèí øèéò ñ ìíîãî äàííè, ùå ñîðòèðàì ïî êîëîíà À ,è íàâñÿêúäå êúäåòî èìàì åäíàêâè ñòîéíîñò â êîëîíà À äà ñå ãåíåðèðà àâòîìàòè÷íî íîâ ôàéë(ïî âúçìîæíîñò ÊÌË, íî ìîæå è csv).Òðÿáâà èìåòî íà ôàéëà äà áúäå êàêâàòî ñòîéíîñò å â êîëîíà À.
    Ïðèìåð:
    1 äàííè
    1 äàííè
    1 äàííè
    1 äàííè
    1 äàííè
    1 äàííè
    2 äàííè
    2 äàííè
    2 äàííè
    2 äàííè
    2 äàííè
    2 äàííè
    3 äàííè
    3 äàííè
    3 äàííè
    3 äàííè
    3 äàííè
    3 äàííè
    4 äàííè
    4 äàííè
    4 äàííè
    4 äàííè
    4 äàííè
    Case: Lancool-215 /MB: Asus Prime B450- Plus/CPU: AMD Ryzan 5800X3D /GeForce RTX™ 4090 GAMING OC / PSU: Super Flower Leadex III 750W /2x16GB DDR4 3600 Kingston FURY/LG 27GL850-B/TV LG OLED 55B9 / VR: HP Reverb 2

  2. #2
    Registered User hateras's Avatar
    Join Date: Jan:2011
    Location: Kronos III
    Posts: 1,028
    Äàííèòå îò ñòðàíèöà 1, êîëîíà À îò ðåä 1 äî êúäåòî èìà äàííè /ïúðâà ïðàçíà êëåòêà â êîëîíà À/ ñå êîïèðàò â íîâ workbook êîéòî ñå çàïèñâà êàòî XLS ôàéë /îôèñ 1997 - 2003 ôîðìàò/.
    Ðåäîâåòå ñå îáõîæäàò ïàê äî êúäåòî èìà äàííè /ïúðâàòà ïðàçíà êëåòêà íà ðåäà/. Ò.å. ìîæå äà èìà ðåäîâå ñ ðàçëè÷íà äúëæèíà.
    Àêî äàííèòå íå ñà ñîðòèðàíè ïî êîëîíà À, èëè êîëîíàòà ñúäúðæà íåùà êîèòî íå ñà ãîäíè çà èìå íà ôàéë ïðåäïîëàãàì ùå ñòàíå ìàçàëî. Èìàé ãðèæàòà äà ñè ñðåøåø äàííèòå, ïëñ :-P
    Edit: Ñìåíè "Sheet1" ñ èìåòî íà øèèòà îò êîéòî ùå ñå âçèìàò äàííèòå!
    Code:
    Sub DataExport()
    Dim NewWB As Workbook
    Dim NewWS As Worksheet
    Dim OldWB As Workbook
    Dim OldWS As Worksheet
    
    Dim colctr1, colctr2 As Integer
    
    Set OldWB = ActiveWorkbook
    'replace "Sheet1" with appropriate value!
    Set OldWS = OldWB.Worksheets("Sheet1")
    Set NewWB = Workbooks.Add
    Set NewWS = NewWB.Worksheets.Add
    
    currentcat = ""
    colctr1 = 1
    a1cat = Trim(CStr(OldWS.Cells(colctr1, 1)))
    While a1cat <> ""
        If a1cat <> currentcat Then
            If currentcat <> "" Then
                'store data from the current temp_sheet
                NewWB.SaveAs OldWB.Path + "\" + currentcat, xlAddIn8
                'clear tmp_sheet
                NewWS.Cells.Clear
            End If
            currentcat = a1cat
            NewWS.Name = currentcat
            colctr2 = 1
        End If
        NewWS.Cells(colctr2, 1) = a1cat
        'copy remaining rows too
        rc = 2
        rw = Trim(CStr(OldWS.Cells(colctr1, rc)))
        While rw <> ""
            NewWS.Cells(colctr2, rc) = rw
            rc = rc + 1
            rw = Trim(CStr(OldWS.Cells(colctr1, rc)))
        Wend
        colctr2 = colctr2 + 1
        colctr1 = colctr1 + 1
        a1cat = Trim(CStr(OldWS.Cells(colctr1, 1)))
    Wend
    'last data group
    If currentcat <> "" Then
        'store data from the current temp_sheet
        NewWB.SaveAs OldWB.Path + "\" + currentcat, xlAddIn8
    End If
    NewWB.Close False
    End Sub
    Last edited by hateras; 28th April 2013 at 16:20.
    ASRock B550M Pro 4; Ryzen R5 3600; 2x16 GiB G.SKILL Aegis 3200; 1TB Samsung QVO 960 + 3TB Seagate IronWolf; Zalman Z1

  3. #3
    Registered User
    Join Date: Aug:2005
    Location: Bugaria
    Posts: 652
    Áëàãîäàðÿ òè, ñòðàõîòíà ðàáîòà ìè ñâúðøè.
    Íå ìîæåø äà ñè ïðåäñòàâèø êîëêî ðàáîòà ìè ñïåñòè
    Case: Lancool-215 /MB: Asus Prime B450- Plus/CPU: AMD Ryzan 5800X3D /GeForce RTX™ 4090 GAMING OC / PSU: Super Flower Leadex III 750W /2x16GB DDR4 3600 Kingston FURY/LG 27GL850-B/TV LG OLED 55B9 / VR: HP Reverb 2

  4. #4
    Registered User hateras's Avatar
    Join Date: Jan:2011
    Location: Kronos III
    Posts: 1,028
    Ìîãà, ìîãà
    ASRock B550M Pro 4; Ryzen R5 3600; 2x16 GiB G.SKILL Aegis 3200; 1TB Samsung QVO 960 + 3TB Seagate IronWolf; Zalman Z1

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Copyright © 1999-2011 Õàðäóåð ÁÃ. Âúçìîæíî å ñúäúðæàíèåòî íà òàçè ñòðàíèöà äà å îáåêò íà àâòîðñêè ïðàâà.
iskamPC.com | mobility.BG | Bloody's Techblog | Êðèïòîâàëóòè è ìàéíèíã | 3D Vision Blog | Ìàãàçèí çà åëåêòðîííè öèãàðè