'ЭТО ВСЕ работатет для 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