画面上で選択したセルに処理をする

Private Sub CmdExecute_Click()

    '
    On Error GoTo Err_Handle

    '-------------------   Excel起動     ----------
    Call ExcelInit
    
    Dim ExBk As Workbook:               Dim ExSt As Worksheet
    Set ExBk = ExcelApp.ActiveWorkbook: Set ExSt = ExcelApp.ActiveSheet
    
        
    '-------------------   文字列を取得     ----------
    Dim strAddStr As String
    
    strAddStr = frmEditSpName.TxtString.Text
    
    If strAddStr = "" Then
        MsgBox "文字列が空", vbCritical + vbMsgBoxSetForeground, Me.Caption
        Exit Sub
    End If
    
    '-------------------   セル文字列を取得     ----------
    Dim i As Long: Dim j As Long: Dim k As Long
    Dim strBuff As String
    Dim strArray() As String
    
    Dim lngRow As Long
    
    strBuff = ExcelApp.ActiveWindow.RangeSelection.Address
    strArray = Split(strBuff, ",")
    
    ReDim strCell(ExcelApp.ActiveWindow.RangeSelection.Count) As String

    
    '選択したC列の文字列（打点名)を配列に代入
    k = 0
    For i = 0 To UBound(strArray)
    
        'Error Processing
        If ExSt.Range(strArray(i)).Columns.Count <> 1 Or ExSt.Range(strArray(i)).Column <> 3 Then
            MsgBox "打点名の列を以外を指定", vbCritical + vbMsgBoxSetForeground, Me.Caption
            Exit Sub
        End If
        
        '開始行
        lngRow = ExSt.Range(strArray(i)).Row
        
        For j = 0 To ExSt.Range(strArray(i)).Rows.Count - 1
            
            strCell(k) = ExSt.Cells(lngRow + j, 3).Value
            'Debug.Print strCell(k)
            
            k = k + 1
            
        Next j
            
    Next i
    
    
    '-------------------   選択したC列のセルに入力     ----------
    k = 0
    For i = 0 To UBound(strArray)
        
        '開始行
        lngRow = ExSt.Range(strArray(i)).Row
        
        For j = 0 To ExSt.Range(strArray(i)).Rows.Count - 1
            
            ExSt.Cells(lngRow + j, 3).Value = strCell(k) + strAddStr
            'Debug.Print strCell(k)
            
            k = k + 1
            
        Next j
            
    Next i
    
    MsgBox "終了", vbInformation + vbMsgBoxSetForeground, Me.Caption
    
    'Excel解放
    Set ExcelApp = Nothing
    
    Exit Sub
    
    
Err_Handle:
    'Excel解放
    Set ExcelApp = Nothing
    MsgBox Err.Source & vbCr & Err.Description, vbCritical
 
End Sub
	    

---

<戻る>

楽天モバイル[UNLIMITが今なら1円] ECナビでポインと Yahoo 楽天 LINEがデータ消費ゼロで月額500円〜！

無料ホームページ 無料のクレジットカード 海外格安航空券 解約手数料０円【あしたでんき】 海外旅行保険が無料！ 海外ホテル