20161212xlVBA worksheet data Organize merged cells

Sub nextseven_codeframe () ' Application settings application.screenupdating = False Application.DisplayAlerts = False application . Calculation = Xlcalculationmanual ' Error handling On Error GoTo ErrHandler ' timer Dim StartTime, usedtime as Variant St Arttime = VBA. Timer ' variable declaration Dim Wb As Workbook Dim Sht As Worksheet Dim openwb As Workbook Dim Osht As Worksheet Dim i&a MP;, j& Dim Rng As Range Dim Arr As Variant Dim endrow As Long Dim RowCount As Long Dim colcount as Lon G Dim FilePath as String ' instantiation object Set Wb = Application.thisworkbook ' Select Single file with Application.filedialog (Msofi Ledialogfilepicker). AllowMultiSelect = False. InitialFileName = Wb.path ' Specifies the initialization path. Filters.clear. Filters.add "Excel File", "*.xls;*.xlsx" If. Show =-1 Then FilePath =. SelectedItems (1) Else Exit Sub End If End with Set OPENWB = Application.Workbooks.Open (File Path) Set Osht = Openwb.worksheets(1) with Osht Set Rng = Application.intersect (. Usedrange.offset (1),. UsedRange) RowCount = Rng.Rows.Count ColCount = Rng.Columns.Count ARR = rng.value for i = Lbou nd (arr) to UBound (arr) ' long digit plus single quote arr (i, 2) = "'" & Arr (i, 2) arr (i, ten) = "'" & Ar  R (I, ten) arr (i, +) = "'" & arr (i, +) = "'" & Arr (i, 18) = "'" & Arr (i, 18) ' Transpose relationship arr (i, I) = arr (i, 2) arr (i, 2) = Arr (i, 1) arr (i , 1) = "" "Next I End with openwb.close False Set Sht = wb.worksheets (1) with SHT. Usedrange.offset (6). Clear ' pre-clears Set Rng =. Range ("A7"). Resize (RowCount, colcount) rng.value = Arr ' Import content End with Dim rowstart As Object Dim rowscount As Objec T Dim Key As String Dim OneKey As Variant Set Rowstart = CreateObject ("Scripting.Dictionary") Set Rowscount = CreateObject ("SCRipting.dictionary ") Mergecolumnno = 2 ' keyword in column for i = LBound (arr, 1) to UBound (arr, 1) key = CStr (arr (i,        Mergecolumnno)) If rowstart.exists (key) = False then Rowstart (key) = i rowscount (key) = 1 Else Rowscount (key) = Rowscount (key) + 1 End If Next i mergecols = Array ("A", "B", "D", "O", " P "," Q "," R "," S "," T "," U "," V "," W "," X "," Z ") ' Merge columns for each OneKey in Rowstart.keys for n = LBound (Mergeco LS) to UBound (Mergecols) rng.cells (Rowstart (OneKey), Mergecols (n)). Resize (Rowscount (OneKey), 1). Merge Next n Next OneKey Const Headrow as Long = 6 Dim Index as long with Sht Endrow =. Cells (. Cells.Rows.Count, 2). End (Xlup). Row Index = 0 for i = headrow + 1 to Endrow If. Cells (i, 2). Value <> "Then index = index + 1. Cells (i, 1). Value = Index End If Next i End with setedges Rng CUSTOMFOrmat rng Union (Sht.range ("A6:z6"), RNG). Columns.AutoFit ' run time Usedtime = VBA. Timer-starttime MsgBox "This Run Time:" & Format (Usedtime, "0.0000000 Seconds") & "--nextseven dedicated to your service.    "Errorexit: ' Error handling ended, start environment cleanup Set Wb = Nothing Set openwb = Nothing Set Sht = Nothing Set Osht = Nothing Set Rng = Nothing Set Rowstart = Nothing Set rowscount = Nothing application.screenupdating = True Applicat Ion. DisplayAlerts = True application.calculation = xlcalculationautomatic Exit suberrhandler:if err.number <> 0 then MsgBox Err.Description & "! ", vbcritical," Error prompt! "' Debug.Print err.description err.clear Resume errorexit End ifend SubSub CustomFormat (ByVal Rng As Range) with Rng. Font.Name = "Song Body". Font.Size = 10. HorizontalAlignment = Xlcenter. VerticalAlignment = Xlcenter End withend Sub

　　

20161212xlVBA worksheet data Organize merged cells