Универсальный поиск для 51 счета

'ЭТО ВСЕ работатет для 51 счета!!!!!! НО БЕЗ КОРРЕКТИРОВОК НА ЗНАЧЕНИЯ (ПРОСТО ИЩЕТ ЗАГОЛОВКИ)
Sub GetKeyColumnsFOR51()

Dim arr() As String
ReDim arr(9)

arr(0) = "Период"
arr(1) = "Документ"
arr(2) = "Аналитика Дт"
arr(3) = "Аналитика Кт"
arr(4) = "Дебет"
arr(5) = "Кредит"
arr(6) = "Текущее сальдо"
arr(7) = "Счет" 'Счет ДЕБЕТ
arr(8) = "Счет" 'Счет КРЕДИТ



Dim arri() As Integer
ReDim arri(9)

jNew = 1
i0 = -1
For ia = 0 To 9

If ia > 9 Then GoTo NEXT_
 
 For i = 1 To 100
   For j = jNew To 30
   
   If ia > 9 Then GoTo NEXT_
   
        If Cells(i, j) = arr(ia) Then
        
          If ia < 5 Then jNew = j
          
           arri(ia) = j  'Формируем массив индексов

           Debug.Print j & " " & arr(ia)
           ia = ia + 1
        End If
   Next j
Next i

Next ia

NEXT_:
'   For Each r In Range("A1:X30")
'      If r.Value = a Then
'         arri(i) = r.Column
'         Debug.Print r.Column & "  " & a
'      End If
'   Next

'For Each a In arri
'  Debug.Print a
'Next


'После того как данные нашли, проверяем объдиненные ячейки. Индексы хранятся уже arri

'''''i = -1
'''''For Each a In arri
''''' i = i + 1
'''''   For Each r In Range("A1:L30")
'''''       r.Select
'''''

       
       

'If r.MergeCells = True And r.Value  "" Then
'          i2 = -1
'           For Each a1 In arr
'               i2 = i2 + 1
'               If r.Value = a1 Then GoTo NEXT_
'           Next
'
'NEXT_:
'          StartColumn = Selection.Column
'          EndColumn = Selection.Column + Selection.Columns.Count - 1
'
'          StartRow = Selection.Row
'          EndRow = Cells.SpecialCells(xlLastCell).Row
'
'          For i = StartRow To EndRow
'            For j = StartColumn To EndColumn
'              If IsNumeric(Cells(i, j).Value) And Cells(i, j).Value  "" Then
'                arri(i2) = j
'              End If
'            Next j
'          Next i
'
'End If

''''   Next
''''Next

i = 0
For Each a In arri
'  Debug.Print arr(i) & " --->" & a
  i = i + 1
Next

' SubcontoD1 = arri(1)
' SubcontoK1 = arri(2)
' SubcontoD2 = arri(3)
' SubcontoK2 = arri(4)
' SubcontoD3 = arri(5)
' SubcontoK3 = arri(6)

End Sub



'ЭТО МОЖНО ЛОМАТЬ!!!!!
Sub GetKeyColumnsFOR51QWQWQWQWQWQWQWQWQWQW()

Dim arr() As String
ReDim arr(9)

arr(0) = "Период"
arr(1) = "Документ"
arr(2) = "Аналитика Дт"
arr(3) = "Аналитика Кт"
arr(4) = "Дебет"
arr(5) = "Кредит"
arr(6) = "Текущее сальдо"
arr(7) = "Счет" 'Счет ДЕБЕТ
arr(8) = "Счет" 'Счет КРЕДИТ



Dim arri() As Integer
ReDim arri(9)

jNew = 1
i0 = -1
For ia = 0 To 9

If ia > 9 Then GoTo NEXT_
 
 For i = 1 To 100
   For j = jNew To 30
   
   If ia > 9 Then GoTo NEXT_
   
        If Cells(i, j) = arr(ia) Then
        
          If ia < 5 Then jNew = j
          
           arri(ia) = j  'Формируем массив индексов

'           Debug.Print j & " " & arr(ia)
           ia = ia + 1
        End If
   Next j
Next i

Next ia

NEXT_:


'После того как данные нашли, проверяем объдиненные ячейки. Индексы хранятся уже arri



Application.ScreenUpdating = False

  For iTOARR = -1 To 6
iTOARR = iTOARR + 1

    For Each r In Range("A6:U15")
       If r.Value = a And r.Value  "" And r.MergeCells = True Then 'Определели ячейки для дальнейшего поиска
          Debug.Print a
          
          r.Select
          
          
          StartColumn = Selection.Column
          EndColumn = Selection.Column + Selection.Columns.Count - 1

          StartRow = Selection.Row
          EndRow = Cells.SpecialCells(xlLastCell).Row

          For i = StartRow To EndRow
            For j = StartColumn To EndColumn
              If IsNumeric(Cells(i, j).Value) And Cells(i, j).Value  "" Then
                arri(iTOARR) = j
              End If
            Next j
          Next i

          
       End If
       
  Next
Next iTOARR
Application.ScreenUpdating = True

'i = -1
'For Each a In arri
' i = i + 1
'   For Each r In Range("A1:X30")
'       r.Select
'
'
'
'If r.MergeCells = True And r.Value  "" Then
'          i2 = -1
'           For Each a1 In arr
'               i2 = i2 + 1
'               If r.Value = a1 Then GoTo NEXT2_
'           Next
'
'NEXT2_:
'          StartColumn = Selection.Column
'          EndColumn = Selection.Column + Selection.Columns.Count - 1
'
'          StartRow = Selection.Row
'          EndRow = Cells.SpecialCells(xlLastCell).Row
'
'          For i = StartRow To EndRow
'            For j = StartColumn To EndColumn
'              If IsNumeric(Cells(i, j).Value) And Cells(i, j).Value  "" Then
'                arri(i2) = j
'              End If
'            Next j
'          Next i
'
'End If
'
'   Next
'Next







i = 0
For Each a In arri
  Debug.Print arr(i) & " --->" & a
  i = i + 1
Next

' SubcontoD1 = arri(1)
' SubcontoK1 = arri(2)
' SubcontoD2 = arri(3)
' SubcontoK2 = arri(4)
' SubcontoD3 = arri(5)
' SubcontoK3 = arri(6)

End Sub

//////////////////////////////////////////////////////////////////////////
ДЛЯ 62 счета
Sub ddd()

 For Each r In Range("A1:M10") 'диапазон для поиска
    If r.Value = "Сумма" Then  ' поиск ячеки искомого текста
      If r.MergeCells Then
         r.Select  ' проверка на объединение
'      Debug.Print Selection.Address(ReferenceStyle:=xlRC, ColumnAbsolute:=True, RowAbsolute:=True);
      Debug.Print Selection.Column 'НАЧАЛЬНОЕ ЗНАЧЕНИЕ СТОЛБЦА
      Debug.Print Selection.Column + Selection.Columns.Count - 1 'КОЛ-ВО столбцов объединено
      
      For i = Selection.Row To 11
        For j = Selection.Column To Selection.Column + Selection.Columns.Count - 1
           If IsNumeric(Cells(i, j).Value) And Cells(i, j).Value  "" Then
              ColumnVal = j
              Debug.Print "Сначение суммы находится в столбце:" & ColumnVal
              Exit Sub
           End If
        Next j
      Next i
      
    End If
  End If
 Next
 
End Sub


Function Garr(ByRef arr() As String)
Dim arr2() As String
ReDim arr2(3)

i = 0
   For Each a In arr
      arr2(i) = a & " Additional text"
      i = i + 1
   Next
   Garr = arr2
End Function


Sub dssdssdsd()
Dim arr() As String
ReDim arr(2)

arr(0) = "AAAA"
arr(1) = "BBBB"
arr(2) = "CCCC"

arr = Garr(arr)

For Each a In arr
  Debug.Print a
Next
End Sub

'===========================================================
'Функция в качестве аргумената получает:
'1. Диапазон для поиска
'2. Массив искомых слов
'           Возвращает массив индексов соотв. слов
'===========================================================


'Function GetKeyColumns(rn As Range, ByRef arr() As String) As Integer
'Dim arri As Integer
'Dim ItemsArr As Integer
'
'ItemsArr = UBound(arr, 1)
'ReDim arri(ItemsArr)
'
'For Each r In rn
'     Select Case r.Value
'         Case arr(0): arri(0) = r.Column
'         Case arr(1): arri(1) = r.Column
'         Case arr(2): arri(2) = r.Column
'         Case arr(3): arri(3) = r.Column
'         Case arr(4): arri(4) = r.Column
'      End Select
'
'Next
'GetKeyColumns = arri
'End Function
'
'Sub TestTest()
'Dim arr() As Integer
'ReDim arr(7)
'
'Dim arr1() As String
'ReDim arr1(7)
'
'arr1(0) = "Счет"
'arr1(1) = "Дебет"
'arr1(2) = "Кредит"
'arr1(3) = "Дебет"
'arr1(4) = "Кредит"
'arr1(5) = "Дебет"
'arr1(6) = "Кредит"
'
'arr = GetKeyColumns(Range("A1:L30"), arr1)
'
'For Each a In arr1
'  Debug.Print a
'Next
'
'End Sub


'Для 62 счетов работает, НО не проверяет на наличие если значения смещены
Sub GetKeyColumns20()

Dim arr() As String
ReDim arr(7)

arr(0) = "Счет"
arr(1) = "Дебет"
arr(2) = "Кредит"
arr(3) = "Дебет"
arr(4) = "Кредит"
arr(5) = "Дебет"
arr(6) = "Кредит"

Dim arri() As Integer
ReDim arri(7)

jNew = 1
i0 = -1
For ia = 0 To 6


If ia > 6 Then GoTo NEXT_
 
 For i = 1 To 100
   For j = jNew To 16
   
   If ia > 6 Then GoTo NEXT_
   
        If Cells(i, j) = arr(ia) Then
           jNew = j
           arri(ia) = j  'Формируем массив индексов
           ia = ia + 1
'           Debug.Print j & " " & a
        End If
   Next j
Next i

Next ia

NEXT_:
'   For Each r In Range("A1:X30")
'      If r.Value = a Then
'         arri(i) = r.Column
'         Debug.Print r.Column & "  " & a
'      End If
'   Next

'For Each a In arri
'  Debug.Print a
'Next


'После того как данные нашли, проверяем объдиненные ячейки. Индексы хранятся уже arri

'''''i = -1
'''''For Each a In arri
''''' i = i + 1
'''''   For Each r In Range("A1:L30")
'''''       r.Select
'''''

       
       

'If r.MergeCells = True And r.Value  "" Then
'          i2 = -1
'           For Each a1 In arr
'               i2 = i2 + 1
'               If r.Value = a1 Then GoTo NEXT_
'           Next
'
'NEXT_:
'          StartColumn = Selection.Column
'          EndColumn = Selection.Column + Selection.Columns.Count - 1
'
'          StartRow = Selection.Row
'          EndRow = Cells.SpecialCells(xlLastCell).Row
'
'          For i = StartRow To EndRow
'            For j = StartColumn To EndColumn
'              If IsNumeric(Cells(i, j).Value) And Cells(i, j).Value  "" Then
'                arri(i2) = j
'              End If
'            Next j
'          Next i
'
'End If

''''   Next
''''Next

i = 0
For Each a In arri
  Debug.Print arr(i) & " --->" & a
  i = i + 1
Next

' SubcontoD1 = arri(1)
' SubcontoK1 = arri(2)
' SubcontoD2 = arri(3)
' SubcontoK2 = arri(4)
' SubcontoD3 = arri(5)
' SubcontoK3 = arri(6)

End Sub

Добавить комментарий

Ваш адрес email не будет опубликован.