(I can't remember very exactly so just waiting for rearrangement)
Public Sub Seiri1() 'output a word per row
Dim iRow, iCol, tempRow As Integer '[iRow, iCol] in unarrange sheet,[tempRow] in "temp sheet"
iRow = 1
iCol = 1
tempRow = 1
'If "Finish" is existed,interrupt
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Finish" Then
MsgBox ("'Finish' already existed,RENAME or DELETE it")
Exit Sub
End If
Next
'$$$ Remember which sheet user choose now
rSheet = ActiveSheet.Index
'Add temporary Sheet
w = ActiveWorkbook.Worksheets.Count 'NOT "ThisWorkbook", USE "ActiveWorkBook" to make Addin
Worksheets.Add After:=Worksheets(w) 'Add "temp sheet" after the last Sheet
Worksheets(w + 1).Name = "temp sheet"
Worksheets.Add After:=Worksheets(w + 1) 'Add "Finish" after "temp sheet"
Worksheets(w + 2).Name = "Finish"
'$$$ Set the sheet actived which just selected by user
Worksheets(rSheet).Select
'Loop while the Cell isn't empty (check the whole row)
10 Do While Not ActiveSheet.Cells(iRow, iCol) = Empty
Worksheets("temp sheet").Cells(tempRow, 1) = ActiveSheet.Cells(iRow, iCol) 'Copy every Cell to temp Sheet
Worksheets("temp sheet").Cells(tempRow, 2) = iRow 'write a row count into temp sheet's 2nd column
iCol = iCol + 1 'Goto next Column
tempRow = tempRow + 1 'Goto next Row in the temp sheet
Loop
iRow = iRow + 1 'The cell is empty(current row ends), goto next row
iCol = 1 'Check from first Column
If ActiveSheet.Cells(iRow, iCol) = Empty Then 'Check whether this is the end of the whole sheet
Seiri2 'this is the end, goto seiri2(next section)
Else
GoTo 10 'it is not the end of the sheet, goto check the whole row
End If
End Sub
'*********************************************************************************************************************************
Private Sub Seiri2() 'make a sheet of 3 columns,middle is the keywords,and finish the arragement
Dim Row, beforeCol, afterCol, beforeColMin, dis As Integer '[Row] in "temp sheet",[beforeCol, afterCol, beforeColMin] in "Finish"
Dim Space As String 'use to add space if the text is english
dis = FormArrange.TextBox1.Text 'control the num of before and after column's words
Row = 1
'if the text is english than add space between words
If FormArrange.OptionButtonEn = True Then
Space = " "
Else
Space = ""
End If
'if the cell is not empty,then loop
10 Do While Not Worksheets("temp sheet").Cells(Row, 1) = Empty
'row count
Worksheets("Finish").Cells(Row, 1) = Worksheets("temp sheet").Cells(Row, 2)
'MIDDLE of the column,a word per row
Worksheets("Finish").Cells(Row, 3) = Worksheets("temp sheet").Cells(Row, 1)
'NEXT to the middle column, link [num of words] words after
For afterCol = Row + 1 To Row + dis
Worksheets("Finish").Cells(Row, 4) = Worksheets("Finish").Cells(Row, 4) & Space & Worksheets("temp sheet").Cells(afterCol, 1)
Next afterCol
'end NEXT
'BEFORE the middle column,link [num of words] words before
Select Case Row 'create a progression of minimum of the beforeCol
Case 1
GoTo 20 'this is the first row,there is no words before,output empty (row=1)
Case 2 To 1 + dis '2nd row to 1 + dis,loop from 1 to row-1 (2<=row<=1+dis)
beforeColMin = 1
Case Else 'from row-dis to row-1 (dis+2<=row)
beforeColMin = Row - dis
End Select
'from minimum to max(always row-1)
For beforeCol = beforeColMin To Row - 1
Worksheets("Finish").Cells(Row, 2) = Worksheets("Finish").Cells(Row, 2) & Space & Worksheets("temp sheet").Cells(beforeCol, 1)
Next beforeCol
'end BEFORE
'finish a row,go to next row
Row = Row + 1
Loop
'delete the temporary sheet and set output column autofit
Application.DisplayAlerts = False 'do not show alert
Worksheets("temp sheet").Delete
Application.DisplayAlerts = True 'set alert to default
Worksheets("Finish").Select
Columns("A:D").EntireColumn.AutoFit
Columns("A:C").EntireColumn.HorizontalAlignment = xlRight
'finish
Exit Sub
'this is the first row, output nothing, and go to next row
20 Worksheets("Finish").Cells(Row, 2) = ""
Row = Row + 1
GoTo 10
End Sub
No comments:
Post a Comment