VBAプログラミング例



  
  
  
  
  1. Const COLUMN_NUM = 20 'クラム�`  
  2. Const TYPE_PK = "PK" 'PKクラム 
  3.  
  4.  
  5. 'PKによってデ�`タ  
  6. Sub FunDataByPk(WSheet As Worksheet, Row_Start As Long, Row_End As Long, Row_Cnt As Long
  7.     '� � �x 
  8.     Dim PK_Array As Variant 
  9.     Dim PK_Count As Integer 
  10.     Dim PK_Array_Value As Variant 
  11.      
  12.     'PK  
  13.     For i = 1 To COLUMN_NUM 
  14.        If Trim(WSheet.Cells(3, i)) = "" Then 
  15.            Exit For 
  16.        End If 
  17.        Tmp_Value = Trim(WSheet.Cells(5, i)) 'PK  
  18.        'PK ��=PKの� � 
  19.        If Tmp_Value = TYPE_PK Then 
  20.            PK_Count = PK_Count + 1 
  21.        End If 
  22.     Next 
  23.      
  24.      
  25.     'PK �{を �x 
  26.     ReDim PK_Array_Value(PK_Count - 1) '  
  27.     ReDim PK_Array(PK_Count - 1) 
  28.     PK_Count = 0 
  29.      
  30.     ' PK  
  31.     For i = LBound(PK_Array_Value) To UBound(PK_Array_Value) 
  32.        PK_Array_Value(i) = 1 
  33.     Next 
  34.     'PK_Array_Value(1) = 9 
  35.      
  36.     'PKを  
  37.     For i = 1 To COLUMN_NUM 
  38.        If Trim(WSheet.Cells(3, i)) = "" Then 
  39.            Exit For 
  40.        End If 
  41.        Tmp_Value = Trim(WSheet.Cells(5, i)) 'PK  
  42.        'PK ��=PKの� � 
  43.        If Tmp_Value = TYPE_PK Then 
  44.            PK_Array(PK_Count) = i 
  45.            PK_Count = PK_Count + 1 
  46.        End If 
  47.     Next 
  48.      
  49.     Dim Column_PK_No As Integer 
  50.     Column_PK_No = 0 '� �  
  51.     Dim No As Long 
  52.     Dim No_Num As Long 
  53.     Dim Var_LNum As Long 
  54.     No_Num = 6 
  55.     No = 1 
  56.     Var_LNum = Row_Start 
  57.      
  58.     For r = Row_Start To (Row_Cnt + Row_Start) 
  59.         For l = 1 To COLUMN_NUM 
  60.             Tmp_Type = Trim(WSheet.Cells(3, l)) 
  61.             Tmp_Byte = VBA.Split(Trim(WSheet.Cells(4, l)), ","
  62.             Tmp_IsPk = Trim(WSheet.Cells(5, l)) 
  63.             If Tmp_Type = "" Then 
  64.                 Var_LNum = l 
  65.                 Exit For 
  66.             End If 
  67.              
  68.             If Tmp_IsPk = TYPE_PK Then 
  69.                  
  70.                 If l = PK_Array(0) Then 
  71.                     If Len(No & "") > Tmp_Byte(0) Then 
  72.                         No = 1 
  73.                         'No_Num = No_Num + 1 
  74.                          
  75.                         Tmp_V = PK_Array_Value(1) + 1 ' PK  
  76.                         PK_Array_Value(1) = Tmp_V 
  77.                          
  78.                     End If 
  79.                     WSheet.Cells(r, l) = No ' PK  
  80.                     No = No + 1 
  81.                 Else 
  82.                     'If Len(No_Num & "") > Tmp_Byte(0) Then 
  83.                         'No_Num = No_Num - 1 
  84.                     'End If 
  85.                     Dim Tmp_Byte_i As Variant 
  86.                     For i = 1 To UBound(PK_Array) 
  87.                         'Tmp_Byte_i = VBA.Split(Trim(WSheet.Cells(4, PK_Array(i))), ",") 
  88.                         Tmp_Byte_i = VBA.Split(Trim(WSheet.Cells(4, PK_Array(i))), ","
  89.                      
  90.                         If Int(Len(PK_Array_Value(i) & "")) > Int(Tmp_Byte_i(0)) Then 
  91.                             
  92.                            PK_Array_Value(i) = PK_Array_Value(i) - 1 
  93.                            If (i + 1) > UBound(PK_Array) Then 
  94.                                For h = 1 To Var_LNum 
  95.                                    WSheet.Cells(r, h).Clear '  
  96.                                Next 
  97.                                Exit Sub 
  98.                            End If 
  99.                            PK_Array_Value(i + 1) = PK_Array_Value(i + 1) + 1 
  100.                         End If 
  101.                     Next 
  102.                      
  103.                     For i = 1 To UBound(PK_Array) 
  104.                         Tmp_Column_i = PK_Array(i) 
  105.                         If Tmp_Column_i = l Then 
  106.                             WSheet.Cells(r, l) = PK_Array_Value(i) 
  107.                         End If 
  108.                     Next 
  109.                 End If 
  110.             End If 
  111.         Next 
  112.     Next 
  113.      
  114.     'MsgBox (Int(UBound(PK_Array)) + 1) 
  115.  
  116. End Sub 
  117.  
  118.  
  119. ' を  
  120. Function GetNumerics(Num As IntegerAs String 
  121.     For i = 1 To Num 
  122.         Tmp = GetNumeric 
  123.         If Tmp = 10 Then 
  124.             If i = 1 Then 
  125.                 Tmp = 1 
  126.             Else 
  127.                 Tmp = 0 
  128.             End If 
  129.         End If 
  130.         GetNumerics = GetNumerics & Tmp 
  131.     Next 
  132. End Function 
  133.  
  134. ' を  
  135. Function GetNumeric() As Integer 
  136.     Do While GetNumeric = 0 
  137.         GetNumeric = Int(Rnd * 11) 
  138.     Loop 
  139. End Function 
  140.  
  141.  
  142. Function Test() 
  143.      
  144.     Dim WSheet As Worksheet 
  145.      
  146.     Set WSheet = Worksheets(1) 
  147.          
  148.     Call FunDataByPk(WSheet, 6, 6, 50000) 
  149.  
  150. End Function