Attribute VB_Name = "rowcommit_gz"
Option Explicit

Sub rowcommit(etalon As Long, beg_dani As Long, shirina As Long)

Dim i As Long, st_len As Long, p As Long, m1 As Long, m2 As Long, f As Long, k As Long, t As Long, shir_max As Long, ws As Worksheet, m As String, len_stolbec As Long
Dim stolbec() As String, mass_dani() As String, stolbci As String

For Each ws In Application.ActiveWorkbook.Worksheets
    ws.Activate
	
	' Объединение ячеек работает только тогда, когда в заданной ячейке есть ключевое слово startcom
	if Left(Cells(3, 1).Value, 8) = "startcom" Then
	    stolbci				= Right(Cells(3, 1).Value, Len(Cells(3, 1).Value) - 8)
	    Cells(3, 1).Value	= ""			' обнуляем ячейку с ключевым словом
		len_stolbec			= Len(stolbci)	' кол-во столбцов для объединения
		
		ReDim stolbec((len_stolbec - 1) / 2 + 1)
	       
		k		= 0
		st_len	= 1
	    
		' Выделяем названия столбцов из строки
		For i = 1 To len_stolbec
	        If Left(stolbci, 1) <> "/" And Mid(stolbci, 2, 1) <> "/" Then
	            st_len = 2
	        End If
	        
			If st_len = 2 Then
	            If Left(stolbci, 1) <> "/" And Mid(stolbci, 2, 1) <> "/" And Mid(stolbci, 2, 1) <> "" Then
	                stolbec(k) = Left(stolbci, st_len)
	                k = k + 1
	            End If
	        Else
	            If Left(stolbci, 1) <> "/" Then
	                stolbec(k) = Left(stolbci, st_len)
	                k = k + 1
	            End If
	        End If
	        stolbci = Right(stolbci, Len(stolbci) - 1)
	    Next
	                    
	    i	= 1
	    f	= beg_dani	   
						
		Cells(f, etalon).Select

	    Do While ActiveCell.Value <> "finish" And ActiveSheet.Rows.Count > f
	        ReDim Preserve mass_dani(2, i)
	        mass_dani(1,i) = Cells(f, etalon+1).Value
	        mass_dani(2,i) = Cells(f, etalon).Row
	        i = i + 1
	        f = f + 1
	        Cells(f, etalon).Select			
	    Loop
	    Cells(f, etalon).Value = ""
	                                          
	    m2	= 1                            	
	    i	= 1
	    p	= 0
	    m1	= 1
	    
		For k = 1 To f - beg_dani
	        If mass_dani(1,k) = mass_dani(1,k - 1) And Trim(mass_dani(1,k - 1)) <> "" Then
				p	= p + 1
			else
				If mass_dani(1,k) <> mass_dani(1,k - 1) And Trim(mass_dani(1,k - 1)) <> "" and p<>0 Then				
	                For i = 0 To (len_stolbec - 1) / 2
						if stolbec(i)<>"" then 
	        	            Range(stolbec(i) + mass_dani(2,k - p-1) + ":" + stolbec(i) + mass_dani(2,k-1)).Select
						    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone                                        	      							
	                	end if      
					Next
	                                  
	                If shirina=0 Then
	                    Rows(mass_dani(2,k - p-1) + ":" + mass_dani(2,k-1)).Select
	                    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
	                End If
				end if 	
	    	  	p=0
			end if

	        If k >= beg_dani Then
	           	Rows(k).EntireRow.AutoFit
	        	Rows(k).EntireRow.AutoFit
		    End If            	  	
	    Next
	End If
Next ws

End Sub

Sub RowCommitXls(cParam As String)
    Dim nParam1 As Long, nParam2 As Long, nParam3 As Long, сParam4 As String

    nParam1 = VBA.CInt(VBA.Trim(GetStrParam(cParam, 1)))
    nParam2 = VBA.CInt(VBA.Trim(GetStrParam(cParam, 2)))
    nParam3 = VBA.CInt(VBA.Trim(GetStrParam(cParam, 3)))
    сParam4 = VBA.CStr(VBA.Trim(GetStrParam(cParam, 4)))
    Call RowCommit(nParam1, nParam2, nParam3, сParam4)
End Sub

Function GetStrParam(lcParam As String, ByVal lnParam As Long, Optional cPart As String = "#") As String
Dim nPos1 As Long, nPos2 As Long, i As Long
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = VBA.InStr(nPos1 + 1, lcParam, cPart)
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = VBA.InStr(nPos1 + 1, lcParam, cPart)
    nPos2 = VBA.IIf(nPos2 = 0, VBA.Len(lcParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = VBA.Mid(lcParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
End Function


