کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی
کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی

ایجادردیف در اکسل با مقدار "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






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




.