Перейти из форума на сайт.

НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Excel VBA (часть 2)

Модерирует : ShIvADeSt

ShIvADeSt (11-01-2010 10:17): http://forum.ru-board.com/topic.cgi?forum=33&topic=10903  Версия для печати • ПодписатьсяДобавить в закладки
На первую страницук этому сообщениюк последнему сообщению

   

AndVGri

Advanced Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору


Код:
 
Private Const FirstRow As Long = 3&
 
Private Function GetOffset(ByVal forCategory As String) As Long
    Dim i As Long, Result As Long
    For i = 2& To Len(forCategory) Step 2&
        If Mid$(forCategory, i, 1&) <> " " Then Exit For
        Result = Result + 2&
    Next i
    GetOffset = Result
End Function
 
Public Sub ToSimpleTable()
    Dim i As Long, pos As Long
    Dim Category0 As String, Category2 As String
    Dim Category4 As String, Category6 As String
    Dim Category8 As String, LastCol As Long
    Dim pSource As Worksheet, pDest As Worksheet
    Dim sValue As String
     
    Set pSource = ActiveSheet
    Set pDest = Worksheets.Add
    pos = 1&: LastCol = pSource.UsedRange.Columns.Count
    Application.ScreenUpdating = False
    pSource.Select
     
    For i = FirstRow To pSource.UsedRange.Rows.Count
        sValue = Trim$(CStr(pSource.Cells(i, 1&).Value))
        If (pSource.Cells(i, 1&).Font.Bold) And (sValue <> "") Then
            Select Case GetOffset(CStr(pSource.Cells(i, 1&).Value))
            Case 0:
                Category0 = sValue
                Category2 = "": Category4 = "": Category6 = "": Category8 = ""
            Case 2:
                Category2 = sValue
                Category4 = "": Category6 = "": Category8 = ""
            Case 4:
                Category4 = sValue
                Category6 = "": Category8 = ""
            Case 6:
                Category6 = sValue
                Category8 = ""
            Case 8:
                Category8 = sValue
            End Select
        ElseIf sValue <> "" Then
            pos = pos + 1&
            pDest.Cells(pos, 1&).Value = Category0
            pDest.Cells(pos, 2&).Value = Category2
            pDest.Cells(pos, 3&).Value = Category4
            pDest.Cells(pos, 4&).Value = Category6
            pDest.Cells(pos, 5&).Value = Category8
            pSource.Range(Cells(i, 1&), Cells(i, LastCol)).Copy pDest.Cells(pos, 6&)
            pDest.Cells(pos, 6&).Value = sValue
        End If
    Next i
    pDest.Select
    Application.ScreenUpdating = True
End Sub
 


Всего записей: 750 | Зарегистр. 14-12-2005 | Отправлено: 04:34 24-04-2007
   

На первую страницук этому сообщениюк последнему сообщению

Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Excel VBA (часть 2)
ShIvADeSt (11-01-2010 10:17): http://forum.ru-board.com/topic.cgi?forum=33&topic=10903


Реклама на форуме Ru.Board.

Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
Modified by Ru.B0ard
© Ru.B0ard 2000-2024

BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

Рейтинг.ru