Filling data in specific way.

M

Matrix335

New Member
Joined
Oct 5, 2015
Messages
27
[/CODE]
I am working on a project which requires to fill the data in specific way. After filling the 3 values in Col3, i should fill the data in Col4. After that i will start filling the data in the Col1 with new row and so on
Please check the following code.

Thank you.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim tAd As Variant
    tAd = Split(Target.Address, "$")
    Dim rowRemainder As Long
    rowRemainder = tAd(2) Mod 3
    
    If tAd(1) = "A" Then
        Range("B" & Target.Row).Activate
    ElseIf tAd(1) = "B" Then
        Range("C" & Target.Row).Activate
    ElseIf tAd(1) = "C" Then
        Range("D" & Target.Row).Activate
    ElseIf tAd(1) = "D" Then
          If rowRemainder = 1 Then
            Range("A" & Target.Row + 1).Activate
         Else
            Range("D" & Target.Row + 1).Activate
            
        End If
    End If
    
End Sub
 

Attachments

  • Filling data.jpg
    Filling data.jpg
    37 KB · Views: 8

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
I know this may be a bit much, but I thought I would offer it anyway. My code allows you to select the input columns when you start it. It waits for you to press enter and determines the next move. AT this point, when a user presses enter in a blank cell, the macro moves down a row. Any entry moves across and then down automatically after a value has been entered into the last selected column. IT could be altered for your needs; such as allowing the cursor to moved to the right even if a blank cell.

VBA Code: 
Sub Fast()

  Dim VarRange As Variant
  Dim ColA As Integer, ColB As Integer, Cell As Range, X As Long
  Dim Count As Integer
  Dim CRLF As String
  
  CRLF = Chr$(10) & Chr$(13)
  
  On Error GoTo JellyBean
  VarRange = Selection.Address    'ActiveCell.Address
  Set VarRange = Application.InputBox("Select the columns in which you want to enter data." & CRLF & "You may select a range of columns or individual columns.", "Fast Data Entry Column Chooser", VarRange, 300, -50, , , 8)
  On Error GoTo 0
  If IsObject(VarRange) = False Then Exit Sub
  
  VarRange.Select
  Col1 = 9999
  Col2 = 0
  X = 0
  Count = VarRange.Count
  ReDim FastCols(Count)
  FastCols(0) = Count
  For Each Cell In VarRange
    X = X + 1
    FastCols(X) = Cell.Column
    If Cell.Column < Col1 Then Col1 = Cell.Column
    If Cell.Column > Col2 Then Col2 = Cell.Column
  Next Cell
  
'  Col1 = Selection.Column
'  Col2 = Selection.Columns.Count + Col1 - 1
  ActiveCell.Offset(0, 1).Select
  ActiveCell.Offset(0, -1).Select

    'Numeric Pad Only
  Application.OnKey "{ENTER}", "Faster"
  Application.OnKey "~", "Faster"
    'If you want the other ENTER Key, Use ~ (tilde)
    
  If StopFastReminder = 0 Then
    MsgBox "You can stop this data entry macro by entering the letter 'Q' in a blank cell", , "Reminder"
    StopFastReminder = 1
  End If
JellyBean:
End Sub
Sub StopFast()
  Application.OnKey "{ENTER}", ""
  Application.OnKey "~", ""
  Application.EnableEvents = True
End Sub

Sub Faster()

  Dim BegCol As Integer, EndCol As Integer
  Dim CC As Integer, Dist As Integer, X As Long
  
  Application.EnableEvents = False
  BegCol = Col1
  EndCol = Col2
  'Dist = BegCol - EndCol
  
  If UCase(ActiveCell.Text) = "Q" Then
    ActiveCell.ClearContents
    Call StopFast
    Exit Sub
  End If

  CC = ActiveCell.Column              'Current Column
  If CC >= BegCol And CC < EndCol Then
    If ActiveCell.Text = "" Then
      ActiveCell.Offset(1, BegCol - CC).Select
    Else
      For X = 1 To FastCols(0)
        If FastCols(X) > CC Then Exit For
      Next X
      ActiveCell.Offset(0, FastCols(X) - CC).Select
    End If
  ElseIf CC > EndCol - 1 Then
    ActiveCell.Offset(1, BegCol - CC).Select
  End If

    Application.EnableEvents = True
End Sub
 
Upvote 0
Is it for data entry? After input done with enter, active cell move right 4 columns, then down 3 rows, then start again from row 4th?
 
Upvote 0
Put it in worksheet chance even (Alt-F11, choose sheet, then paste it in code window)

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&, rT&, cT&
Dim sCell As Range
Set sCell = Range("A2") ' adjust actual start cell
rT = (Target.Row - sCell.Row) Mod 3 ' 3 is rows number each sequence
cT = (Target.Column - sCell.Column) Mod 4 ' 4 is columns number each sequence
If Intersect(Target, sCell.Resize(100000, 4)) Is Nothing Then Exit Sub
    Select Case cT
        Case Is = 3
            Select Case rT
                Case Is < 2
                x = 1: y = 0 'x,y is offset steps of target cell
                Case Else
                x = 1: y = -3
            End Select
        Case Else
        x = 0: y = 1
    End Select
Target.Offset(x, y).Select
End Sub
 
Upvote 0
bebo021999 said:
Put it in worksheet chance even (Alt-F11, choose sheet, then paste it in code window)

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&, rT&, cT&
Dim sCell As Range
Set sCell = Range("A2") ' adjust actual start cell
rT = (Target.Row - sCell.Row) Mod 3 ' 3 is rows number each sequence
cT = (Target.Column - sCell.Column) Mod 4 ' 4 is columns number each sequence
If Intersect(Target, sCell.Resize(100000, 4)) Is Nothing Then Exit Sub
    Select Case cT
        Case Is = 3
            Select Case rT
                Case Is < 2
                x = 1: y = 0 'x,y is offset steps of target cell
                Case Else
                x = 1: y = -3
            End Select
        Case Else
        x = 0: y = 1
    End Select
Target.Offset(x, y).Select
End Sub
Click to expand...
Thank you very much but it did not work. I want the output as on the attached screenshot please.
 

Attachments

  • Filling data.jpg
    Filling data.jpg
    28.5 KB · Views: 6
Upvote 0
Jeffrey Mahoney said:
I know this may be a bit much, but I thought I would offer it anyway. My code allows you to select the input columns when you start it. It waits for you to press enter and determines the next move. AT this point, when a user presses enter in a blank cell, the macro moves down a row. Any entry moves across and then down automatically after a value has been entered into the last selected column. IT could be altered for your needs; such as allowing the cursor to moved to the right even if a blank cell.

VBA Code: 
Sub Fast()

  Dim VarRange As Variant
  Dim ColA As Integer, ColB As Integer, Cell As Range, X As Long
  Dim Count As Integer
  Dim CRLF As String
 
  CRLF = Chr$(10) & Chr$(13)
 
  On Error GoTo JellyBean
  VarRange = Selection.Address    'ActiveCell.Address
  Set VarRange = Application.InputBox("Select the columns in which you want to enter data." & CRLF & "You may select a range of columns or individual columns.", "Fast Data Entry Column Chooser", VarRange, 300, -50, , , 8)
  On Error GoTo 0
  If IsObject(VarRange) = False Then Exit Sub
 
  VarRange.Select
  Col1 = 9999
  Col2 = 0
  X = 0
  Count = VarRange.Count
  ReDim FastCols(Count)
  FastCols(0) = Count
  For Each Cell In VarRange
    X = X + 1
    FastCols(X) = Cell.Column
    If Cell.Column < Col1 Then Col1 = Cell.Column
    If Cell.Column > Col2 Then Col2 = Cell.Column
  Next Cell
 
'  Col1 = Selection.Column
'  Col2 = Selection.Columns.Count + Col1 - 1
  ActiveCell.Offset(0, 1).Select
  ActiveCell.Offset(0, -1).Select

    'Numeric Pad Only
  Application.OnKey "{ENTER}", "Faster"
  Application.OnKey "~", "Faster"
    'If you want the other ENTER Key, Use ~ (tilde)
   
  If StopFastReminder = 0 Then
    MsgBox "You can stop this data entry macro by entering the letter 'Q' in a blank cell", , "Reminder"
    StopFastReminder = 1
  End If
JellyBean:
End Sub
Sub StopFast()
  Application.OnKey "{ENTER}", ""
  Application.OnKey "~", ""
  Application.EnableEvents = True
End Sub

Sub Faster()

  Dim BegCol As Integer, EndCol As Integer
  Dim CC As Integer, Dist As Integer, X As Long
 
  Application.EnableEvents = False
  BegCol = Col1
  EndCol = Col2
  'Dist = BegCol - EndCol
 
  If UCase(ActiveCell.Text) = "Q" Then
    ActiveCell.ClearContents
    Call StopFast
    Exit Sub
  End If

  CC = ActiveCell.Column              'Current Column
  If CC >= BegCol And CC < EndCol Then
    If ActiveCell.Text = "" Then
      ActiveCell.Offset(1, BegCol - CC).Select
    Else
      For X = 1 To FastCols(0)
        If FastCols(X) > CC Then Exit For
      Next X
      ActiveCell.Offset(0, FastCols(X) - CC).Select
    End If
  ElseIf CC > EndCol - 1 Then
    ActiveCell.Offset(1, BegCol - CC).Select
  End If

    Application.EnableEvents = True
End Sub
Click to expand...
Thank you for your help, it did not work.
 
Upvote 0
Matrix335 said:
Thank you very much but it did not work. I want the output as on the attached screenshot please.
Click to expand...
Its quite different vs 1st post. Finally, taget will move as 1 to 10 (6 columns) then back to 1 at 4th row, right? How about 1 in cell A1?
 
Upvote 0
VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&, rT&, cT&
Dim sCell As Range
Set sCell = Range("A2") ' adjust actual start cell
rT = (Target.Row - sCell.Row) Mod 3 ' 3 is rows number each sequence
cT = (Target.Column - sCell.Column) Mod 6 ' 6 is columns number each sequence
If Intersect(Target, sCell.Resize(100000, 6)) Is Nothing Then Exit Sub
    Select Case cT
        Case Is < 3
            x = 0: y = 1
        Case Is < 5
            Select Case rT
                Case Is < 2
                x = 1: y = 0 'x,y is offset steps of target cell
                Case Else
                x = -2: y = 1
            End Select
        Case Else
             Select Case rT
                Case Is < 2
                x = 1: y = 0
                Case Else
                x = 1: y = -5
             End Select
   End Select
Target.Offset(x, y).Select
End Sub
 
Upvote 0
bebo021999 said:
VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&, rT&, cT&
Dim sCell As Range
Set sCell = Range("A2") ' adjust actual start cell
rT = (Target.Row - sCell.Row) Mod 3 ' 3 is rows number each sequence
cT = (Target.Column - sCell.Column) Mod 6 ' 6 is columns number each sequence
If Intersect(Target, sCell.Resize(100000, 6)) Is Nothing Then Exit Sub
    Select Case cT
        Case Is < 3
            x = 0: y = 1
        Case Is < 5
            Select Case rT
                Case Is < 2
                x = 1: y = 0 'x,y is offset steps of target cell
                Case Else
                x = -2: y = 1
            End Select
        Case Else
             Select Case rT
                Case Is < 2
                x = 1: y = 0
                Case Else
                x = 1: y = -5
             End Select
   End Select
Target.Offset(x, y).Select
End Sub
Click to expand...

I am getting the same results even if i change the row & column number each sequence. I tried to modify it but it did not work.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Hide Unhide entire row
Replies
1
Views
283
rollis13
rollis13
M
  • Question
Skip one cell on the first row.
Replies
6
Views
771
rollis13
rollis13
S
  • Solved
VBA: Am I double-calling a Sub given nested If statements? Or other inefficiencies?
Replies
8
Views
249
dreid1011
dreid1011
N
  • Solved
VBA Question
Replies
3
Views
127
RoryA
RoryA
D
  • Solved
VBA Questions For Auto filling Cells
2 3
Replies
23
Views
914
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,025
Messages
6,122,734
Members
449,094
Latest member
dsharae57

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top