Related
I'm working my way through loops and naturally have started off with a challenging one! I have a workbook with multiple sheets. Each sheet has the operations to complete a "widget". I'm trying to walk through a range of cells and search by date to find a matching date. If that date matches, I want to add the std hours in row 7 of that column. I was able to make this work through brut force code and copy and paste my loop for each column. I REALLY DONT want to do this for all the columns on each tab.
I'm sure there is a way to use my counters for last row and last column to do a nested loop so once I complete the loop in one column, it moves to the next. I'm just not sure how to get there. Was hoping for some help on this! Thank you!
edit: essentially what I want to do is start in I12, loop to bottom of column looking for the date then counting the number of times I see that to add up the number of PPC hours (I7). Then, move to J12, loop to bottom of column, move to K12, loop to bottom adding up hours for Assy. Etc...
Sub Resource_Overview()
'Summary of daily tasks by worktype
'Declare the variables we'll need
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim i As Double 'for counters, using double to add up decimals
Dim Assy, Solder, QC, Weld, Test, PPC As Double 'variables to hold std hours total
Dim a As Long
Assy = 0#
Solder = 0#
QC = 0#
Weld = 0#
Test = 0#
PPC = 0#
'Find Last Row and Column
Set sht = ActiveSheet
Set StartCell = Range("I12")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column - 3 '-3 columns to not count need date or ECD info
Set sht = ActiveSheet
Set StartCell = Range("I12")
For i = 12 To LastRow
If Range("I" & i).Value = 44154 Then
If Range("I" & 1) = "Assy" Then
Assy = Assy + Range("I7").Value
ElseIf Range("I" & 1) = "Solder" Then
Solder = Solder + Range("I7").Value
ElseIf Range("I" & 1) = "Weld" Then
Weld = Weld + Range("I7").Value
ElseIf Range("I" & 1) = "Test" Then
Test = Test + Range("I7").Value
ElseIf Range("I" & 1) = "PPC" Then
PPC = PPC + Range("I7").Value
ElseIf Range("I" & 1) = "QC" Then
QC = QC + Range("I7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("J" & i).Value = 44154 Then
If Range("J" & 1) = "Assy" Then
Assy = Assy + Range("J7").Value
ElseIf Range("J" & 1) = "Solder" Then
Solder = Solder + Range("J7").Value
ElseIf Range("J" & 1) = "Weld" Then
Weld = Weld + Range("J7").Value
ElseIf Range("J" & 1) = "Test" Then
Test = Test + Range("J7").Value
ElseIf Range("J" & 1) = "PPC" Then
PPC = PPC + Range("J7").Value
ElseIf Range("J" & 1) = "QC" Then
QC = QC + Range("J7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("K" & i).Value = 44154 Then
If Range("K" & 1) = "Assy" Then
Assy = Assy + Range("K7").Value
ElseIf Range("K" & 1) = "Solder" Then
Solder = Solder + Range("K7").Value
ElseIf Range("K" & 1) = "Weld" Then
Weld = Weld + Range("K7").Value
ElseIf Range("K" & 1) = "Test" Then
Test = Test + Range("K7").Value
ElseIf Range("K" & 1) = "PPC" Then
PPC = PPC + Range("K7").Value
ElseIf Range("K" & 1) = "QC" Then
QC = QC + Range("K7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("L" & i).Value = 44154 Then
If Range("L" & 1) = "Assy" Then
Assy = Assy + Range("L7").Value
ElseIf Range("L" & 1) = "Solder" Then
Solder = Solder + Range("L7").Value
ElseIf Range("L" & 1) = "Weld" Then
Weld = Weld + Range("L7").Value
ElseIf Range("L" & 1) = "Test" Then
Test = Test + Range("L7").Value
ElseIf Range("L" & 1) = "PPC" Then
PPC = PPC + Range("L7").Value
ElseIf Range("L" & 1) = "QC" Then
QC = QC + Range("L7").Value
End If
End If
Next i
For i = 12 To LastRow
If Range("M" & i).Value = 44154 Then
If Range("M" & 1) = "Assy" Then
Assy = Assy + Range("L7").Value
ElseIf Range("M" & 1) = "Solder" Then
Solder = Solder + Range("M7").Value
ElseIf Range("M" & 1) = "Weld" Then
Weld = Weld + Range("M7").Value
ElseIf Range("M" & 1) = "Test" Then
Test = Test + Range("M7").Value
ElseIf Range("M" & 1) = "PPC" Then
PPC = PPC + Range("M7").Value
ElseIf Range("M" & 1) = "QC" Then
QC = QC + Range("M7").Value
End If
End If
Next i
Sheets("Sheet1").Select
Range("B2") = PPC
Range("B3") = Assy
Range("B4") = Solder
Range("B5") = QC
End Sub
So you can build your range:
Range(A1:D1) -> Range(Cells(A1), Cells(D1)) ->
Range(Cells(row number, column number), Cells(row number, column number)) ->
Range(Cells(1, 1), Cells(1, 4))
If the range is "A1". We can write either Range(Cells(1, 1), Cells(1, 1)) or use cell reference Cells(1,1).
To build ranges with loop you can replace some of the numbers with letters that represent the loop value, i.e. column/row number.
Without testing but I think you will get the logic:
Sub Resource_Overview()
'Summary of daily tasks by worktype
'Declare the variables we'll need
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim i As, j As Long 'I always use long
Dim Assy, Solder, QC, Weld, Test, PPC As Double 'variables to hold std hours total
Dim a As Long
Assy = 0#
Solder = 0#
QC = 0#
Weld = 0#
Test = 0#
PPC = 0#
'Find Last Row and Column
Set sht = ActiveSheet
Set StartCell = Range("I12")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column - 3 '-3 columns to not count need date or ECD info
Set sht = ActiveSheet
For i = 9 To LastColumn 'Set from which column number you want the loop to start from
For j = 12 To LastRow
If Cells(j,i).Value = 44154 Then
If Cells(1,i).Value = "Assy" Then
Assy = Assy + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Solder" Then
Solder = Solder + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Weld" Then
Weld = Weld + Cells(7,i).Value
ElseIf Cells(1,i).Value = "Test" Then
Test = Test + Cells(7,i).Value
ElseIf Cells(1,i).Value = "PPC" Then
PPC = PPC + Cells(7,i).Value
ElseIf Cells(1,i).Value = "QC" Then
QC = QC + Cells(7,i).Value
End If
End If
Next j
Next i
Sheets("Sheet1").Range("B2") = PPC
Sheets("Sheet1").Range("B3") = Assy
Sheets("Sheet1").Range("B4") = Solder
Sheets("Sheet1").Range("B5") = QC
End Sub
Sub OpenFile()
Dim temp_fdr As String
Dim test_fdr As String
Dim model_selector As String
Dim path As String
Dim Keyword_range As Range
'--------------------------------------------------------복사 할 영역 선택 변수
Dim Cont_R, Mov_T, Mov_V, Open_V As String
Dim Cont_R_row, Mov_T_row, Mov_V_row, Open_V_row, Test_T_row As Integer
Dim Cont_R_col, Mov_T_col, Mov_V_col, Open_V_col, Test_T_col As Integer
Dim realDataStartRow As Integer
Dim realDataEndRow As Long
Dim t1Rng As Range
Dim t2Rng As Range
Dim t3Rng As Range
Dim t4Rng As Range
Dim t5rng As Range
Dim t1Arr, t2Arr, t3Arr, t4Arr, t5Arr
'------------------------------------------------------- 시험 폴더 지정을 위한 변수 선언
today_total = Format(Date, "yyyy-mm-dd")
today_year = Format(Year(Date), "0000")
today_month = Format(Month(Date), "00")
today_day = Format(Day(Date), "00")
Dim lastModifiedFdr As String
'-------------------------------------------------------- 그래프 오리지널 폴더 -------------------나중에 바꿀 path
Dim chtWorkbookPath As String
Dim chtWorkbook As Workbook
Dim chtSheet As Worksheet
chtWorkbookPath = ThisWorkbook.path
Debug.Print chtWorkbookPath
'Set chtWorkbook = "C:\Users\bjkwack\Desktop\실시간그래프도식화작업중\" & today_year & "-" & today_month & ".xlsm"
' Debug.Print chtWorkbook
'-------------------------------------------------------- 현재 시험폴더 찾아가기------------------------------
' lastModifiedFdr = Module2.lastModifiedFdr
'MsgBox lastModifiedFdr
If Len(lastModifiedFdr) = 0 Then
temp_fdr = "\\172.30.145.135\evr data\" & today_year & "-" & today_month & "\" & today_day & "\"
lastModifiedFdr = Module2.LastFolder(temp_fdr)
End If
test_fdr = "\\172.30.145.135\evr data\" & today_year & "-" & today_month & "\" & today_day & "\" & lastModifiedFdr & "\"
'MsgBox test_fdr
'-----------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------- 시험 파일 위치지정
On Error Resume Next
Application.DisplayAlerts = False
Workbooks.Open Filename:=test_fdr & "\" & today_total & ".xls", ReadOnly:=True
Application.DisplayAlerts = True
Debug.Print test_fdr
Debug.Print lastModifiedFdr
'Workbooks("" & today_total & ".xls").Sheets(1).Activate
With ActiveSheet.UsedRange '---------------------------------------------------------- s = 출력물에서 2월 데이터 영역
Set Keyword_range = .Find(What:="접촉저항", LookAt:=xlWhole) '--------------------- 접촉저항 행 열 요소 찾기
On Error Resume Next
'Cont_R_row = Keyword_range.Row
On Error Resume Next
Cont_R_col = Keyword_range.Column
Debug.Print Cont_R_col
Set Keyword_range = .Find(What:="동작시간(ms)", LookAt:=xlWhole) '--------------------- 동작시간 행 열 요소 찾기
On Error Resume Next
'Mov_T_row = Keyword_range.Row
On Error Resume Next
Mov_T_col = Keyword_range.Column
Debug.Print Mov_T_col
Set Keyword_range = .Find(What:="석방전압(V)", LookAt:=xlWhole) '--------------------- 개방전압 행 열 요소 찾기
On Error Resume Next
'Open_V_row = Keyword_range.Row
On Error Resume Next
Open_V_col = Keyword_range.Column + 1 '--------------------*** 실제 데이터 열 보다 한칸 +1 에 있음 ***********
Set Keyword_range = .Find(What:="흡인전압(V)", LookAt:=xlWhole) '--------------------- 동작전압 행 열 요소 찾기
On Error Resume Next
'Mov_V_row = Keyword_range.Row
On Error Resume Next
Mov_V_col = Keyword_range.Column + 1 '--------------------*** 실제 데이터 열 보다 한칸 +1 에 있음 ***********
Set Keyword_range = .Find(What:="시험시간", LookAt:=xlWhole) '--------------------- 시험시간 행 열 요소 찾기
'On Error Resume Next
Test_T_row = Keyword_range.Row
Test_T_col = Keyword_range.Column
Debug.Print Test_T_row
Debug.Print Test_T_col
realDataStartRow = .Cells(Test_T_row, Test_T_col).End(xlDown).Row
realDataEndRow = .Cells(Rows.Count, Test_T_col).End(xlUp).Row
Debug.Print realDataStartRow
Debug.Print realDataEndRow
Set t1Rng = .Range(Cells(realDataStartRow, Test_T_col), Cells(realDataEndRow, Test_T_col))
Set t2Rng = .Range(Cells(realDataStartRow, Cont_R_col), Cells(realDataEndRow, Cont_R_col))
Set t3Rng = .Range(Cells(realDataStartRow, Mov_T_col), Cells(realDataEndRow, Mov_T_col))
Set t4Rng = .Range(Cells(realDataStartRow, Mov_V_col), Cells(realDataEndRow, Mov_V_col))
Set t5rng = .Range(Cells(realDataStartRow, Open_V_col), Cells(realDataEndRow, Open_V_col))
Debug.Print t1Rng
t1Arr = t1Rng.Value
t2Arr = t2Rng.Value
t3Arr = t3Rng.Value
t4Arr = t4Rng.Value
t5Arr = t5rng.Value
Debug.Print t2Arr
Debug.Print t3Arr
.Range("ab5").Resize(UBound(t1Arr, 1)).Value = t1Arr
.Range("ac5").Resize(UBound(t2Arr, 1)).Value = t2Arr
.Range("ad5").Resize(UBound(t3Arr, 1)).Value = t3Arr
.Range("ae5").Resize(UBound(t4Arr, 1)).Value = t4Arr
.Range("af5").Resize(UBound(t5Arr, 1)).Value = t5Arr
End With
' Selection.NumberFormatLocal = "h:mm:ss;#"
End Sub
You can use Application.Transpose to copy values from a column into a row
Dim rng As Range
'set the source range
Set rng = Range("A1:A5")
'copy to a column
Range("C1").Resize(rng.Rows.Count, 1).Value = rng.Value
'copy to a row
Range("E1").Resize(1, rng.Rows.Count).Value = Application.Transpose(rng.Value)
Note there's an upper limit to the size of the array you can transpose (~65k items I think)
I wrote this macro to pull data from a separate workbook to do some string manipulation. (Not shown) Eventually the code uses the data stored in the arrays created to create work instructions. Code shown below with one section working as intended (bend array creation), the second section will not (csk array creation). When I step through the code it will not go to the 'next i' and exits the if statement entirely on the first iteration.
nbends = Application.WorksheetFunction.CountIf(Range("M6:M" & lastrow), "BEND RADIUS")
ncsksf = Application.WorksheetFunction.CountIf(Range("M6:M" & lastrow), "CSK FARSIDE")
ncsksn = Application.WorksheetFunction.CountIf(Range("M6:M" & lastrow), "CSK NEARSIDE")
ReDim Bends(1 To nbends, 1 To 5)
ReDim Csksn(1 To nscksn, 1 To 3)
'' Bend array creation
On Error Resume Next
Set r = Range("M6:M" & lastrow).Find(what:="BEND RADIUS", LookIn:=xlValues)
If Not r Is Nothing Then
firstaddress = r.Address
addressrow = Right(firstaddress, 2)
Bends(1, 1) = Range("A" & addressrow)
Bends(1, 2) = Range("C" & addressrow)
Bends(1, 3) = Range("A" & addressrow + 1)
Bends(1, 4) = Range("M" & addressrow + 1)
Bends(1, 5) = Range("B" & addressrow + 1)
Do
For i = LBound(Bends) + 1 To UBound(Bends)
Set r = Range("M" & addressrow & ":M" & lastrow).Find(what:="BEND RADIUS", LookIn:=xlValues)
firstaddress = r.Address
addressrow = Right(firstaddress, 2)
Bends(i, 1) = Range("A" & addressrow)
Bends(i, 2) = Range("C" & addressrow)
Bends(i, 3) = Range("A" & addressrow + 1)
Bends(i, 4) = Range("M" & addressrow + 1)
Bends(i, 5) = Range("B" & addressrow + 1)
Next i
Loop While Not r Is Nothing And r.Address <> firstaddress
End If
'' Csks array creation
On Error Resume Next
Set r = Range("M6:M" & lastrow).Find(what:="CSK NEARSIDE", LookIn:=xlValues)
If Not r Is Nothing Then
firstaddress = r.Address
addressrow = Right(firstaddress, 2)
Csksn(1, 1) = Range("A" & addressrow)
Csksn(1, 2) = Range("B" & addressrow)
Csksn(1, 3) = Range("M" & addressrow)
Debug.Print addressrow
Do
For i = LBound(Csksn) + 1 To UBound(Csksn)
Set r = Range("M" & addressrow & ":M" & lastrow).Find(what:="CSK NEARSIDE", LookIn:=xlValues)
firstaddress = r.Address
addressrow = Right(firstaddress, 2)
Csksn(i, 1) = Range("A" & addressrow)
Csksn(i, 2) = Range("B" & addressrow)
Csksn(i, 3) = Range("M" & addressrow)
Debug.Print r
Debug.Print firstaddress
Debug.Print addressrow
Next i
Loop While Not r Is Nothing And r.Address <> firstaddress
End If
I fixed this by changing the for loop parameters to
For i = 2 To ncsksn
Set r = Range("M" & addressrow & ":M" & lastrow).Find(what:="CSK NEARSIDE", LookIn:=xlValues)
firstaddress = r.Address
addressrow = Right(firstaddress, 2)
Csksn(i, 1) = Range("A" & addressrow)
Csksn(i, 2) = Range("B" & addressrow)
Csksn(i, 3) = Range("M" & addressrow)
Debug.Print r
Debug.Print firstaddress
Debug.Print addressrow
Next i
Loop While Not r Is Nothing And r.Address <> firstaddress
End If
and it will print the values for each variable (r, firstaddress, addressrow) at each iteration of the for loop; but when i go to print the array using this loop nothing appears.
For i = LBound(Csksn) To UBound(Csksn)
For j = LBound(Csksn) To UBound(Csksn)
Debug.Print i, j, Csksn(i, j)
Next j
Next i
What am I missing here?
Thank you all for your knowledge
I am carrying out a project for my company. I have created an array and stored some data inside.
I need to print or paste the array in the body of an email.
You can notice below that in the object .Body = "Hello, " & vbNewLine & vbNewLine & "Could you confirm the net amount below?" & T(p + 1, 8)
The array T(p+1,8) doesn't appear in the body of the mail.
Below the code:
On Error Resume Next
With OutMail
.to = Address
.CC = "otcequityderivativesettlement#xxxxxx.com"
.BCC = ""
.Subject = "Amount to confirm Value Date" & " " & VALUEDATE & " " & CTPY
.Body = "Hello, " & vbNewLine & vbNewLine & "Could you confirm the net amount below?" & T(p + 1, 8)
.Attachments.Add "R:\Fmp\Fmp10\All\POLE DERIVES ACTIONS\SSI xxxxx\SSI xxxx.pdf"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Sub Macro()
Dim i As Variant
Dim l As Long
Dim p As Long
Dim mySIay() As Variant
Dim DataRange As Range
Dim cell As Range
Dim x As Long
Dim CSico As Long
Dim CTradeID As Long
Dim CBusinessEvent As Long
Dim CNetAmount As Long
Dim CTradeDate As Long
Dim CPaymentDate As Long
Dim CMaturity As Long
Dim CNominal As Long
Dim Label As Variant
Dim ra As Range
Dim T() As Variant
Dim DSum As Double
Dim DSum2 As Double
Dim p2 As Variant
Dim Address As String
l = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
p = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
ps = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
Dim CTPY As String
Dim VALUEDATE As Date
Dim Contacts As String
ReDim T(p + 1, 8)
For i = 1 To l
If Cells(1, i).Value = "Value Date" Then VALUEDATE = Cells(2, i).Value
Next i
For i = 1 To l
If Cells(1, i).Value = "Counterparty" Then CTPY = Cells(2, i).Value
Next i
'Primo
Set ra = Cells.Find(What:="Sicovam", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Sicovam not found")
Else
Dim SI() As Variant
i = 0
ReDim SI(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
SI(i) = cell
i = i + 1
ReDim Preserve SI(i)
Next
End If
'Secondo
Set ra = Cells.Find(What:="Trade ID", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Trade ID not found")
Else
Dim TI() As Variant
i = 0
ReDim TI(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
TI(i) = cell
i = i + 1
ReDim Preserve TI(i)
Next
End If
'Terzo
Set ra = Cells.Find(What:="Business Event", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Business Event not found")
Else
Dim BE() As Variant
i = 0
ReDim BE(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
BE(i) = cell
i = i + 1
ReDim Preserve BE(i)
Next
End If
'Quarto
Set ra = Cells.Find(What:="Net Amount", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Net Amount not found")
Else
Dim NA() As Variant
i = 0
ReDim NA(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
NA(i) = cell
i = i + 1
ReDim Preserve NA(i)
Next
End If
'Quinto
Set ra = Cells.Find(What:="Trade Date", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Trade Date not found")
Else
Dim TD() As Variant
i = 0
ReDim TD(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
TD(i) = cell
i = i + 1
ReDim Preserve TD(i)
Next
End If
'Sesto
Set ra = Cells.Find(What:="Payment Date", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Payment Date not found")
Else
Dim PD() As Variant
i = 0
ReDim PD(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
PD(i) = cell
i = i + 1
ReDim Preserve PD(i)
Next
End If
'Settimo
Set ra = Cells.Find(What:="Maturity", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Maturity not found")
Else
Dim MA() As Variant
i = 0
ReDim MA(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
MA(i) = cell
i = i + 1
ReDim Preserve MA(i)
Next
End If
'Ottavo
Set ra = Cells.Find(What:="Nominal", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If ra Is Nothing Then
MsgBox ("Nominal not found")
Else
Dim NO() As Variant
i = 0
ReDim NO(0)
Range(ra, ra.End(xlDown)).Select
i = 0
For Each cell In Range(ra, ra.End(xlDown))
NO(i) = cell
i = i + 1
ReDim Preserve NO(i)
Next
End If
For i = 0 To p
T(i, 1) = SI(i)
Next i
For i = 0 To p
T(i, 2) = TI(i)
Next i
For i = 0 To p
T(i, 3) = BE(i)
Next i
For i = 0 To p
T(i, 4) = NA(i)
Next i
For i = 0 To p
T(i, 5) = TD(i)
Next i
For i = 0 To p
T(i, 6) = PD(i)
Next i
For i = 0 To p
T(i, 7) = MA(i)
Next i
For i = 0 To p
T(i, 8) = NO(i)
Next i
With Application.WorksheetFunction
DSum = .Sum(.Index(T, 0, 5))
End With
DSum2 = Int(DSum * 100)
DSum = DSum2 / 100
T(p, 4) = DSum
T(p, 0) = "TOTAL"
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
ActiveSheet.Range("B" & p + 1 & ":I" & 2 * p + 1) = T()
ActiveSheet.Range("B" & p + 1 & ":I" & 2 * p + 1).Copy
'For i = 1 To p2
'If Worksheets("Sheet2").Cells(i, 2).Value = CTPY Then Address = Worksheets("Sheet2").Cells(i, 4).Value
'Next i
Address = Application.WorksheetFunction.VLookup(CTPY, _
Worksheets("Sheet2").Range("B:D"), 3, 1)
On Error Resume Next
With OutMail
.to = Address
.CC = ""
.BCC = ""
.Subject = "Amount to confirm Value Date" & " " & VALUEDATE & " " & CTPY
.Body = "Hello, " & vbNewLine & vbNewLine & "Could you confirm the net amount below?" & T(p + 1, 8)
.Attachments.Add ""
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End Sub
can you suggest me a routine - algorithm in VBA that can take the following String as an input:
"A14, A22, A23, A24, A25, A33"
and turn it to this:
"A14, A22 - A25, A33"
?
Thank you
EDIT:
Thanks to #omegastripes
Sub Test()
Dim strText, strRes, strTail, i
Dim comma As String: comma = ", "
Dim dash As String: dash = "-"
Dim delimiter As String
Dim counter As Integer
strText = "A14, A22, A23, A24, A25, A26, A33, A34"
strRes = ""
strTail = ""
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "([a-zA-Z])(\d+)"
With .Execute(strText)
strRes = .Item(0).Value
For i = 1 To .Count - 1
If (.Item(i).SubMatches(0) = .Item(i - 1).SubMatches(0)) And (.Item(i).SubMatches(1) - .Item(i - 1).SubMatches(1) = 1) Then
counter = counter + 1
If counter > 1 Then
delimiter = dash
Else
delimiter = comma
End If
strTail = delimiter & .Item(i).SubMatches(0) & .Item(i).SubMatches(1)
Else
Debug.Print "strRes: " & strRes & ", " & "strTail: " & strTail & ", " & .Item(i).SubMatches(1)
strRes = strRes & strTail & ", " & .Item(i).SubMatches(0) & .Item(i).SubMatches(1)
strTail = ""
counter = 0
End If
Next
strRes = strRes & strTail
End With
End With
MsgBox strText & vbCrLf & strRes
End Sub
this should do
Function HideValues(inputStrng As String) As String
Dim outputStrng As String, iniLetter As String, endLetter As String
Dim vals As Variant, val As Variant
Dim iVal As Long, iniVal As Long, endVal As Long, diffVal As Long
vals = Split(WorksheetFunction.Substitute(inputStrng, " ", ""), ",")
iVal = 0
Do While iVal < UBound(vals)
iniVal = getValNumber(vals(iVal), iniLetter)
endVal = getValNumber(vals(iVal + 1), endLetter)
If iniLetter = endLetter Then
diffVal = 1
Do While endVal = iniVal + diffVal And iVal < UBound(vals) - 1
diffVal = diffVal + 1
iVal = iVal + 1
endVal = getValNumber(vals(iVal + 1), endLetter)
Loop
If diffVal > 1 Then
If iVal = UBound(vals) - 1 Then If endVal = iniVal + diffVal Then iVal = iVal + 1: diffVal = diffVal + 1
outputStrng = outputStrng & vals(iVal - diffVal + 1) & " - " & vals(iVal) & ","
Else
outputStrng = outputStrng & vals(iVal) & ","
End If
Else
outputStrng = outputStrng & vals(iVal) & ","
End If
iVal = iVal + 1
Loop
If iVal = UBound(vals) Then outputStrng = outputStrng & vals(iVal) & ","
HideValues = WorksheetFunction.Substitute(Left(outputStrng, Len(outputStrng) - 1), ",", ", ")
End Function
Function getValNumber(val As Variant, letter As String) As Long
Dim strng As String
Dim i As Long
strng = CStr(val)
For i = 1 To Len(strng)
If Mid(strng, i, 1) Like "[0-9]" Then Exit For
Next i
letter = Left(strng, i - 1)
getValNumber = CLng(Right(strng, Len(strng) - i + 1))
End Function
I tested it with the following:
Sub main()
Dim inputStrng As String
inputStrng = "A21, B22, C23, D24, E25, F26"
MsgBox inputStrng & vbCrLf & vbCrLf & "becomes" & vbCrLf & vbCrLf & HideValues(inputStrng)
inputStrng = "A21, A22, A23, A24, A25, A26"
MsgBox inputStrng & vbCrLf & vbCrLf & "becomes" & vbCrLf & vbCrLf & HideValues(inputStrng)
inputStrng = "A21, A22, A23, A24, A25, A33" '
MsgBox inputStrng & vbCrLf & vbCrLf & "becomes" & vbCrLf & vbCrLf & HideValues(inputStrng)
inputStrng = "A14, A22, A23, A24, A25, A33"
MsgBox inputStrng & vbCrLf & vbCrLf & "becomes" & vbCrLf & vbCrLf & HideValues(inputStrng)
inputStrng = "A14, A22, A23, A24, A25, A26"
MsgBox inputStrng & vbCrLf & vbCrLf & "becomes" & vbCrLf & vbCrLf & HideValues(inputStrng)
End Sub
Here is an example showing how you can hide sequential values with regex:
Option Explicit
Sub Test()
Dim strText, strRes, strTail, i
strText = "A14, A22, A23, A24, A25, A33"
strRes = ""
strTail = ""
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "([a-zA-Z])(\d+)"
With .Execute(strText)
strRes = .Item(0).Value
For i = 1 To .Count - 1
If (.Item(i).SubMatches(0) = .Item(i - 1).SubMatches(0)) And (.Item(i).SubMatches(1) - .Item(i - 1).SubMatches(1) = 1) Then
strTail = "-" & .Item(i).SubMatches(0) & .Item(i).SubMatches(1)
Else
strRes = strRes & strTail & ", " & .Item(i).SubMatches(0) & .Item(i).SubMatches(1)
strTail = ""
End If
Next
strRes = strRes & strTail
End With
End With
MsgBox strText & vbCrLf & strRes
End Sub
And the output:
Roughly you can do it like this.
Sub Way()
Dim str1 As String
Dim cet As variant
Dim str2 As String
str1 = "A14, A22, A23, A24, A25, A33"
cet = split(str1, ",")
if len(join(cet)) > 2 then
str2 = cet(0) & "," & cet(1) & "-" & cet(Ubound(cet)-1) & "," & cet(ubound(cet))
End if
debug.Print str2
End Sub