ایجادردیف در اکسل با مقدار "insert "در سلول در رنج تعیین شده

فرض کنید در سل خاصی مقداری را وارد می کنید و می خواهید بعد از مقدار دادن یک ردیف جدید ایجاد گردد. در کد زیر اگر insert در سلول b2 تا b20 وارد شود یک ردیف جدید ایجاد می گردد.

Sub InsertRowswithSpecificValue()

Dim cell As Range

For Each cell In Range("b2:b20")

    If cell.Value = "insert" Then

        cell.EntireRow.Insert

    End If

Next cell

End Sub

در کد زیر Date در ستون A درج میشود و اگر چیزی در ستون B وارد کنید از Row 2 آغاز می شود.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Long

On Error GoTo SkipError 

If Target.Column = 2 And Target.Row > 1 Then 

Application.EnableEvents = False

r = Target.Row

If Target <> "" Then

If Cells(r, "A") = "" Then

Cells(r, "A") = Date

End If

Else

Cells(r, "A") = ""

End If

End If

SkipError:

Application.EnableEvents = True

End Sub

کد زیر : فرض شده در ستونی کد A تا فرضا D ( به تعداد دلخواه و نامرتب یا سورت نشده ) و مقدارشان هم در ستون کناری قید گردیده در ستون های دیگر قرار است کد یونیک و کنارش جمع کد یونیک ها زده شود ... ممکن است کد نیاز به دستکاری  داشته باشد ولی راهکار همین است.درستون A و ردیف یک آیتم های A تا D به تعداد دلخواه و نامرتب وارد شود و کنارشان اعداد دلخواه.

Sub CountCodes()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Dim wbk As Workbook
Dim ws As Worksheet
Dim wsRow As Long, newRow As Long Dim Names() As String
Dim Found As Boolean
Dim Cell As Range
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
ReDim Names(0 To 0) As String

newRow = 1
With ws

گرفتن آخرین ردیف در ستون A

wsRow =.Range("A" & .Rows.Count).End(xlUp).Row

 ستون A که شامل آیتم های A تا D است را درون آرایه قرار می دهد. لوپی میزند از سلول ردیف ۲ و ستون یک یعنی کالمن A تا سلول آخرین ردیف از ستون یک تابعی نوشته شده که اگر Found برابر False یا صفر شد آرایه مقدار را در خودش بگیرد بخاطر همین از Preverse استفاده شده که آرایه پویا باشد وگرنه اگر استانیک باشد اگر تعداد به آرایه اضافه شود ارور ایندکس میدهد می توانید امتحان بنمائید. البته از Pivot Table هم میشود بهره برد ولی برای زمانیست که می خواهید کلاس بگذارید و آیتم ها همراه با جمع یا شمارش را برای گزارش گیری در شیت یا ناحیه کاری دیگری قرار دهید ... در هر صورت موفق باشید اگر گزینه های دیگری هم داشتید می توانید در لوپ فیلتر کردن با ز هم از For....Each درون همان For....Each استفاده کنید.

For Each Cell In .Range(.Cells(2, 1), .Cells(wsRow, 1))

Found = (IsInArray(Cell.Value2, Names) > -1)

If Found = False Then

Names(UBound(Names)) = Cell.Value2

If Cell.Row <> wsRow Then

ReDim Preserve Names(0 To UBound(Names) + 1) As String

End If

End If

در پائین لوپی زده شده در آرایه از پائین ترین سطح تا بالاترین ،  از AutoFilter برای فیلتر کردن ستون A1 استفاده شده و یکی یکی مقادیر داخل آرایه در شرط آن قرار میگیرد

For x = LBound(Names) To UBound(Names) 

Range("A1").AutoFilter Field:=1, Criteria1:=Names(x)

For Each Cell In .Range("A1:A" & wsRow).SpecialCells(xlCellTypeVisible)

myCount = myCount + 1

Next

اگر myCount بزرگتر از یک شود لوپی در رنج B که حاوی مقادیر است زده و آنها را با هم جمع می کند.

If myCount > 1 Then

For Each Cell In .Range("B2:B" & wsRow).SpecialCells(xlCellTypeVisible)

mySum = mySum + Cell.Value2

Next

مقادیر داخل تابع Names که آیتم های A تا D را در خود دارد در سلولی که در ستون 6 است درج می گردد و همینطور جمع اعدادشان در ستون 9 و ردیف هم که از یک شروع می شود

newRow = newRow + 1

.Cells(newRow, 6) =Names(x) 

.Cells(newRow, 9) = mySum

End If 

myCount = 0

mySum = 0

Next

'Remove Filter

.ShowAllData

End With 

With Application .ScreenUpdating = True

.Calculation = xlCalculationAutomatic

End With

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Long

Dim i As Long

IsInArray = -1

For i = LBound(arr) To UBound(arr)

If StrComp(stringToBeFound, arr(i),vbTextCompare) = 0 Then

IsInArray = i

Exit For

End If

Next i

End Function

کد زیر یک Blank Line در زیر ردیفی که مقدارصفر در ستون مربوطه وارد میشود ایجاد میکند.

Sub BlankLine()

Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next

xTitleId= "Relax"
Set WorkRng= Application.Selection

Set WorkRng=Application.InputBox("Range", xTitleId, WorkRng.Address, Type: = 8)

Set WorkRng= WorkRng.Columns(1)

xLastRow= WorkRng.Rows.Count

Application.ScreenUpdating = False

For xRowIndex = xLastRow To 1 Step - 1

Set Rng= WorkRng.Range("A" & xRowIndex)

If Rng.Value = "0" Then
Rng.Offset(1, 0).EntireRow.Insert Shift: = xlDown
End If

Next

Application.ScreenUpdating = True

End Sub

دوستان گل  تمامی کدها از سایت ها استخراج شده جهت سهولت کاری شما عزیزان  لطفا لطفا در نظر سنجی شرکت کنید

.