memo of MS.Excel.VBA V

Purpose
  Count used cells in excel excluding the blank ones

Function RowCount() as long
dim i
dim bEnd as Boolean
dim strCell

i=0
Do while(Not bEnd)
      strCell=ActiveSheet.cells(i,1)
      if trim(strCell)="" then
            bEnd=True
      Else
            i=i+1
      End If
Loop
RowCount=i

End Function

memo of MS.Excel.VBA IV

Purpose
  (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

memo of MS.Excel.VBA III

Purpose
  (I can't remember very exactly so just waiting for rearrangement)


Sub DassyChain()
'by Franklin.Q 2008-12-09

Dim iRow, iCol, RowCt, ColCt, i, j, k As Integer
Dim Sum As Double
RowCt = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count
ColCt = ActiveWorkbook.ActiveSheet.UsedRange.Columns.Count

iRow = RowCt
iCol = ColCt + 1
k = 1

rSheet = ActiveSheet.Index
w = ActiveWorkbook.Worksheets.Count
Worksheets.Add After:=Worksheets(w)
Worksheets(rSheet).Select

For j = 1 To iCol
Select Case Judge(j)
Case 1
Cells(1, j) = "V"
Case 2
Cells(1, j) = "I"
Case 3
Cells(1, j) = "R"
For i = 1 To iRow
Cells(i + 1, j).Value = Cells(i + 1, j - 2).Value / Cells(i + 1, j - 1).Value
Sum = Sum + Cells(i + 1, j).Value
Next i
Cells(iRow + 2, j).Value = Sum / (iRow - 1)
Sum = 0
Worksheets(w + 1).Cells(k, 1).Value = Cells(iRow + 2, j).Value
k = k + 1
End Select

Next j

Worksheets(w + 1).Select

End Sub

Function Judge(n) As Integer
If n > 3 Then
Select Case (n Mod 3)
Case 0
Judge = 3
Case 1
Judge = 1
Case 2
Judge = 2
End Select
Else
Judge = n
End If
End Function

memo of MS.Excel.VBA II

Purpose
  (I can't remember very exactly so just waiting for rearrangement)

Sub Adachi()

'by Franklin.Q 2008-12-04

Dim RowCt, ColCt, Ct, loopRow, nData, startRow, endRow, startCol, endCol, i As Integer

loopRow = 0

Ct = 0

nData = 0

RowCt = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count

ColCt = ActiveWorkbook.ActiveSheet.UsedRange.Columns.Count

For Each c In ActiveSheet.Range(Cells(1, 1), Cells(RowCt, 1))

  If Not (c.Value = 0) And Ct = 0 Then

  nData = nData + 1

  End If

  

  If c.Value = 0 Then

    Ct = Ct + 1

  End If

  

  If Ct = 1 Then

  loopRow = loopRow + 1

  End If

Next c

loopRow = loopRow - 1

For i = 1 To Ct

 If i = 1 Then

  startRow = nData + 1

  endRow = startRow + loopRow

  startCol = 1

  endCol = startCol + ColCt - 1

 Else

  Range(Cells(nData + 1, startCol), Cells(nData + 1 + loopRow, endCol)).Value = _

  Range(Cells(startRow, 1), Cells(endRow, ColCt)).Value

  Range(Cells(1, startCol), Cells(1, endCol)).Value = _

  Range(Cells(1, 1), Cells(1, ColCt)).Value

  Range(Cells(startRow, 1), Cells(endRow, ColCt)).ClearContents

End If

 startRow = endRow + 1

 endRow = startRow + loopRow

 startCol = endCol + 1

 endCol = startCol + ColCt - 1

Next i

With ActiveSheet.Range(Cells(nData + 1, 1), Cells(nData + 1 + loopRow, ActiveSheet.UsedRange.Columns.Count)).Select

  Selection.NumberFormatLocal = "0.00E+00"

  Selection.Columns.AutoFit

  

End With

End Sub