assfhshffhsfskfh
Printable View
assfhshffhsfskfh
In support of answer for this post.
https://excelfox.com/forum/showthrea...3470#post13470
Text file supplied Sample2.csv ( Avinash : https://excelfox.com/forum/showthrea...ll=1#post13470
sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t )
Open in/ with Excel: ( Like: this: https://imgur.com/7pAaLVx , https://excelfox.com/forum/showthrea...ll=1#post13440 , for example with text editorCode:NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
,100,,,,,,,,,,,,,,,,,,,,,,
,25,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Before runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,After runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,100,,,,,,,,,
,,,,,,,,,,,,,,25,,,,,,,,,
OpenSample2_csvManually with Excel.JPG : https://imgur.com/e7CxxpV)
Attachment 2963
_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )
Worksheet: sample2
Row\Col NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,, NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,, NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,, ,100,,,,,,,,,,,,,,,,,,,,,, ,25,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,Before runing the macro,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,After runing the macro,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT ,,,,,,,,,,,,,,100,,,,,,,,, ,,,,,,,,,,,,,,25,,,,,,,,,
Open with Excel VBA:
see next post : https://excelfox.com/forum/showthrea...ll=1#post13476Code:Sub OpenVBASample2_csv_5June() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
' see next post : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )Code:Sub OpenVBASample2_csv_5June() '
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
Worksheet: sample2
Row\Col NSE < A GTT NSE < A GTT NSE < A GTT Only for understanding purpose Before runing the macro NSE < A GTT NSE < A GTT NSE < A GTT After runing the macro NSE < A GTT NSE < A GTT NSE < A GTT
Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell
Sample2After.csv
Code:NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,,
,25,,,,,,,,,,
In Excel ( open manually )
Open Sample2_csv Manually with Excel.JPG : https://imgur.com/9QNhxrA
_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )
Worksheet: Sample2After
Row\Col NSE,101010,6,<,12783,A,,,,,GTT NSE,22,6,<,12783,A,,,,,GTT NSE,17388,6,<,12783,A,,,,,GTT ,100,,,,,,,,,, ,25,,,,,,,,,,
In Excel VBA
_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )Code:_ Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
Worksheet: Sample2After
Row\Col NSE < A GTT NSE < A GTT NSE < A GTT
Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell
Code:Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToRwCnt)
Code:"NSE" & Chr(44) & "101010" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & Chr(44) & "100" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & "25" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf
Macro for this post:
https://excelfox.com/forum/showthrea...ll=1#post13470
Code:' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470
Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndExcelFileConditions()
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim Lr As Long: Let Lr = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT
Let RwCnt = RwCnt + 1
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = ""
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z
Rem 3 Do it
For Cnt = 2 To Lr ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If
Else
' Neither of the 2 conditions are met so do nothing
End If
Next Cnt
Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToRwCnt)
'Rem 6 Check File in Excel VBA open
'' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'
End Sub
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo
Macro for this post
https://excelfox.com/forum/showthrea...-condition-met
Code:Sub VBAAppendDataToExcelFileRowBasedOnTwoExcelFileConditions2() ' https://excelfox.com/forum/showthread.php/2517-Copy-and-paste-the-data-if-condition-met Previous macro where second file is .csv text file https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("Sample1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Rem 2 sample2.xlsx
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Sample2.xlsx")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
Dim NxtRw As Long: Let NxtRw = RwCnt2 + 1 ' next free row in sample2.xlsx
' 2d) second column in sample2.xlsx up maximum size of sample1.xls - that will be the biggest size needed
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & Lr1 & "").Value ' Clm2Sample2xlsx.JPG
Rem 3 Do it
Dim Cnt As Long
For Cnt = 2 To Lr1 ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs1(Cnt, 11) > arrWs1(Cnt, 4) And arrWs1(Cnt, 8) > arrWs1(Cnt, 11)) Or (arrWs1(Cnt, 11) < arrWs1(Cnt, 4) And arrWs1(Cnt, 8) < arrWs1(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of Sample2.xls Clm2()
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I of of 1.xls with second column data of sample2.xlsx
' Match Column I of sample1.xls with second column (column B) of sample2.xlsx
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to second column values (column B) of sample2.xlsx
Let Clm2(NxtRw, 1) = arrWs1(Cnt, 9)
If NxtRw <> Lr1 Then Let NxtRw = NxtRw + 1 ' If we are not already at the maximum possible row in column B, Ws2 , then we need to adjust NxtRw for next possible missing match
End If
Else
' Neither of the 2 conditions are met so do nothing
End If
Next Cnt
Rem Paste out adjusted/ added to Ws2 column B
Ws2.Range("B1:B" & Lr1 & "").Value = Clm2()
End Sub
sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
sample2.xlsx : https://app.box.com/s/np7kbvjydnyiu95pzyrgn76qi1uqg0ma
vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m
Macro to answer this Thread
https://excelfox.com/forum/showthrea...ete-entire-row
Code:Sub STEP9t() ' https://excelfox.com/forum/showthread.php/2520-Conditionally-compare-the-data-amp-delete-entire-row
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 Alert.xls
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Alert.xls")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
'1_2d) second column in Alert.xls
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & RwCnt2 & "").Value
Rem 3
Dim Cnt As Long, MtchRes As Variant
For Cnt = UBound(arrS1(), 1) To 2 Step -1 ' "row" count, Cnt
Select Case arrS1(Cnt, 10) ' column I
Case "BUY" 'If column J of 1.xls has buy then
If arrS1(Cnt, 8) < arrS1(Cnt, 4) Then ' column H of 1.xls is not greater than column D of 1.xls
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If:
Else
End If
Case "" ' If column J of 1.xls has a blank cell then
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Case "SHORT" 'If column J is SHORT then
If arrS1(Cnt, 8) > arrS1(Cnt, 4) Then ' column H of 1.xls is Greater than than column D
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Else
End If
End Select
Next Cnt
End Sub
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Alert.xls : https://app.box.com/s/ectstkrcfnuozys9tmdd0qi3tdvyxb3w
Macro for this post:
https://excelfox.com/forum/showthrea...ata-if-matches
Code:Sub AddColumnJValueInWs1basedOnMatchAndCritzeriaInWs2() ' https://excelfox.com/forum/showthread.php/2556-copy-and-paste-of-data-if-matches
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
'1_1b) data range
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 AlertCodes.xlsx
Dim WbA As Workbook, WsA4 As Worksheet
Set WbA = Workbooks("AlertCodes.xlsx")
Set WsA4 = WbA.Worksheets.Item(4)
Dim RwCnt4 As Long: Let RwCnt4 = WsA4.Range("A" & WsA4.Rows.Count & "").End(xlUp).Row
'1_2b) dataa range
Dim arrWsA4() As Variant: Let arrWsA4() = WsA4.Range("A1:K" & RwCnt4 & "").Value2
'1_2d) second column in Alertcodes.xlsx
Dim ClmB() As Variant: Let ClmB() = WsA4.Range("B1:B" & RwCnt4 & "").Value
Rem 3
Dim Cnt As Long
For Cnt = 2 To Lr1 ' going down "rows" in 1.xls
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrWs1(Cnt, 9), ClmB(), 0) ' match column I of 1.xls with sheet4 of column B of Alertcodes.xlsx
If IsError(MtchRes) Then
' do nothing - no match
Else ' look at symbol in column D, 4th worksheet of AlertCodes.xlsx for that matched row in column D, 4th worksheet of AlertCodes.xlsx
If arrWsA4(MtchRes, 4) = ">" Then ' If symbol is > then
Let arrS1(Cnt, 10) = "SHORT" ' put SHORT in column J of 1.xls for the matched row
ElseIf arrWsA4(MtchRes, 4) = "<" Then ' If symbol < then
Let arrS1(Cnt, 10) = "BUY" ' put BUY in column J of 1.xls for the matched row
Else
End If
End If
Next Cnt
Rem 4 Paste back out arrS1()
Let Ws1.Range("A1:J" & Lr1 & "").Value2 = arrS1()
End Sub
AlertCodes.xlsx : https://app.box.com/s/jwpjjut9wt3ej7dbns3269ftlpdr7xsm
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m
In support of these posts
https://excelfox.com/forum/showthrea...ll=1#post13617
https://excelfox.com/forum/showthrea...ll=1#post13470
sample2BEFORE.csv
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
Code:"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf
sampLE2AFTER.csvCode:"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,
,25,,,,,,,,,
Code:"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf
Code:"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf
https://excelfox.com/forum/showthrea...ll=1#post13617
sampLE2AFTER.csv : https://drive.google.com/file/d/1Tyf...gWwzZ3s43YxzwA
sample2BEFORE : https://drive.google.com/file/d/1X2M...vIqNATRC34o5hD
app.box.com
Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
Previous files:
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo
Macro for this post:
https://excelfox.com/forum/showthrea...ll=1#post13617
Code:Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndExcelFileConditions2() ' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim LR As Long: Let LR = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "sample2BEFORE.csv" ' "sample2_9June.csv" ' "sample2 8June.csv" ' "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Not EOF(FileNum) = True And Left(TextFileLineIn, 4) = "NSE," ' Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT that may have extra unwanted lines like in one Avinash uses stupidly for explanations
Let RwCnt = RwCnt + 1 ' for first and subsequent lines given by below. ... but
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
If EOF(FileNum) = True Then Let RwCnt = RwCnt + 1 ' ... but if the last line I want is EOF, I will not catch it in the loop so must add a 1 here
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = "" '_- so this can be used again for next line(row)
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z
Rem 3 Do it
For Cnt = 2 To LR ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If
Else
' Neither of the 2 conditions are met so do nothing
End If
Next Cnt
Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToRwCnt)
Rem 6 Check File in Excel VBA open
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'Dim Wb As Workbook
' Set Wb = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\sample2.csv")
End Sub
Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Question 1
Solution for this question, ( 2020-05-28 22:13:09 Rajesh Kumar )
https://excel.tips.net/T002145_Dynam...Tab_Names.html
Question: ( Question 1 )
......I have a list of 80 students. I have made 80 sheets, 1 sheet for 1 student. I want to rename these 80 sheets on the basis of the name in the list, so that whenever I update the name list, the corresponding sheet-name changed automatically. I'm a beginner in this field. Please help me.
Solution.
Hello Rajesh
This requirement is fairly easy with VBA
There are 3 macros which I have written for you, and I am returning 2 workbook examples
Macro for your original requirement
Private Sub Worksheet_Change(ByVal Target As Range)
This macro is in both workbooks:
It does this: If you change any of your names in column B of the worksheets, then the name of the corresponding worksheet tab Name will change, as per your main original requirement.
Workbook AddNamesfromListToExistingWorksheets.xlsm
This is the workbook supplied by you. It has initially 80 student names in column B of the first worksheet. It has 80 additional worksheets , as made by you, with the names of 1 2 3 4 5 …. Etc.
This workbook has a macro , Sub ChangeNamesToExistingWorksheets() . This macro replaces those names with the names from the Student name list in column B
Workbook AddWorksheetsNamedFromList.xlsm
This is your original Workbook, with all but the first worksheet deleted. So this only contains one worksheet containing your list of student Names in column B
In this workbook, there is a macro, Sub AddWorksheetsfromListOfNames()
This macro adds worksheets with the student Names
Note: in your supplied data, you had two identical names at row 26 and at row 75, SACHIN KUMAR , so I changed it to SACHIN KUMAR 2 in row 75
( We could handle such cases in coding, automatically, later if you preferred )
Alan
Workbooks:
Share ‘AddNamesfromListToExistingWorksheets.xlsm’ : https://app.box.com/s/2ytj6qrsyaudh3tzgtodls8l05zn1woz
Share ‘AddWorksheetsNamedFromList.xlsm’ : https://app.box.com/s/yljwyk5ykxtjt2qhzvdpwcrft19phx54
For macros, see also post https://excelfox.com/forum/showthrea...ll=1#post13444
Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynam...Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/thread...value.1135674/
Macros for this post ( Question 1 )
https://excelfox.com/forum/showthrea...ll=1#post13443
Code:Option Explicit
' https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13443 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13444
Sub RemoveAllButThisWorksheet()
Dim Cnt
For Cnt = ThisWorkbook.Worksheets.Count To 2 Step -1 ' second worksheet counting tab from the left is worksheets item 2
Let Application.DisplayAlerts = False
ThisWorkbook.Worksheets.Item(Cnt).Delete
Let Application.DisplayAlerts = True
Next Cnt
End Sub
Sub ChangeNamesToExistingWorksheets() '
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant ' The .Value2 property in the next line will return a field of values housed in Variant type Elements, so we need to give the variant type to our array used to capture that array of values
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2 ( column B )
Let Worksheets.Item(Cnt).Name = arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub
Sub AddWorksheetsfromListOfNames()
Rem 0
On Error GoTo Bed
Let Application.EnableEvents = False
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt
Bed:
Let Application.EnableEvents = True
End Sub
'
'
Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim Rng As Range
Set Rng = Ws1.Range("B2:B" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
Let ThisWorkbook.Worksheets.Item(Rw).Name = Target.Value ' In the list, each row number corresponds to the item number of our worksheets made from that list
Else
' changed cell was not in Student name list
End If
End Sub
Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynam...Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/thread...value.1135674/
Macro for these posts ( Question 2 )
https://excelfox.com/forum/showthrea...ll=1#post13442
https://excelfox.com/forum/showthrea...ll=1#post13448
Code:' _1. I want to create 5 tabs (Sheets) on the basis of these 5 names. (Now the workbook will have 6 tabs, including Master Sheet) https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNames2() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt
Bed:
Let Application.EnableEvents = True
End Sub ' (Now the workbook will have 6 tabs, including Master Sheet)
Sub AddHypolinkToWorksheet() ' https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2
Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 1 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenWyatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim Rng As Range
Set Rng = Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
Exit Sub
Else
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
End If
Else
' changed cell was not in Student name list
End If
'
Call AddHypolinkToWorksheet
End Sub
Share ‘DynamicWorksheetNamesLinkHideBasedOnCellValu e. : https://app.box.com/s/louq07ga6uth1508e572l7zr9fakont9
Macros for this post
https://excelfox.com/forum/showthrea...ll=1#post13456
Add Workseets from names list, for example from :
_____ Workbook: DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m ( Using Excel 2007 32 bit )
Worksheet: Master Sheet
Row\Col ANUJ RITA MUKESH RAM RAHIN Anshu
Code:' _1. I want to create tabs (Sheets) on the basis of names. https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNamesC() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt
Worksheets.Item(1).Select
Bed:
Let Application.EnableEvents = True
End Sub '
Add hypelinks to Worksheets
Code:Sub AddHypolinkToWorksheet()
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2
Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 4 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenWyatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt - 3, 1) & "'!$A$1" ' "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("C" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt - 3, 1), TextToDisplay:=arrNmes(Cnt - 3, 1) ' Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub
'
Event macros
Code:'
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456
'If Target.Column = 1 And Not IsArray(Target.Value) Then ' we are in column A , And we selected one cell
If Target.Column = 3 And Not IsArray(Target.Value) Then ' we are in column C , And we selected one cell
Set LRng = Target
Else
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
If Not LRng Is Nothing And Target.Value = "" And LRng.Row = Lr1 + 1 Then Let Lr1 = Lr1 + 1
Dim Rng As Range
Set Rng = Ws1.Range("C4:C" & Lr1 & "") ' Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Or Target.Value = "-" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
Let Application.EnableEvents = False
Let Target.Value = ""
Let Application.EnableEvents = True
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = False
Exit Sub
Else
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
' Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Name = Target.Value
End If
Else
' changed cell was not in Student name list
End If
'
Call AddHypolinkToWorksheet
End Sub
Top 2 lines of code module
Code:Option Explicit
Dim LRng As Range
File:
DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m : https://app.box.com/s/alo1fbzx8r41jd81rttghikytqzvm0w9
kkfhhfsfhsah
In suppot of this forum post
https://www.excelforum.com/excel-pro...ml#post5340103
Code:' Alert 29May excelforum..csv https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html
'If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has a blank cell
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has short & column H of 1.xls is Greater than than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
' With Sheets(1)
' Lr = .Range("a" & Rows.Count).End(xlUp).Row
' Missed 3 dots.
' With GetObject(fn)
' With .Sheets(1)
' Lr = .Range("a" & .Rows.Count).End(xlUp).Row
Sub OpenAlert29Mayexcelforum__csv()
Workbooks.Open Filename:=ThisWorkbook.Path & "\Alert 29May excelforum..csv"
End Sub
Sub JindonsTesties() ' Conditionally compare the data & delete entire row - https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html#post5340103
' PART 1 ================================
Dim LR As Long, e ', fn As String ' , myCSV As String, txt As String, vTemp As Variant, arrTemp() As Variant
Rem 1 Workbooks, Worksheets info
' fn = ThisWorkbook.Path & "\1.xls" '"C:\Users\WolfieeeStyle\Desktop\1.xls"
' myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' If (Dir(fn) = "") + (Dir(myCSV) = "") Then MsgBox "Invalid file Path/Name": Exit Sub
Dim Wb1 As Workbook
Set Wb1 = Workbooks("1.xls") ' CHANGE TO SUIT
' Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' CHANGE TO SUIT
'With GetObject(fn)
'With .Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Let LR = Ws1.Range("a" & Ws1.Rows.Count).End(xlUp).Row ' 1.xls last row of data
Rem 2 Make 1 Dimensional arrays for values
'2a) If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
'Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim arrTemp() As Variant
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim txt As String
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is empty
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2b) If column J of 1.xls has short & column H of 1.xls is Greater than column D of 1.xls
' Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {100}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2c) If column J of 1.xls has a blank
' Let vTemp = .Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {15083, 17388}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'End With ' final txt is And (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
'.Close
'End With
' CreateNew myCSV, Mid$(txt, 5)
' Let txt = Mid$(txt, 6) ' take off the first " AND "
' Part 2 ===============================================================================
'End Sub
'Sub MyTests_CreateNew()
Rem 3 source text file
'3a) source text file
Dim myCSV As String ' , txt As String
Let myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' Call CreateNew(myCSV, Mid$(txt, 5))
'End Sub
'Private Sub CreateNew(myCSV As String, txt As String)
Dim fn As String ' , cn As Object, rs As Object, x
' 3b Make copy of test file , make temporary file
fn = Left$(myCSV, InStrRev(myCSV, "\")) & "tempComma.csv"
Dim PathAndFileName As String: Let PathAndFileName = fn
FileCopy myCSV, fn ' FileCopy source, destination https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filecopy-statement
Rem 4 ADODB stuff
'4a)
Dim Cn As Object: Set Cn = CreateObject("ADODB.Connection")
With Cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Text;HDR=No;"
'.Open Left(fn, InStrRev(fn, "\"))
Dim PathOnly As String: Let PathOnly = Left(fn, InStrRev(fn, "\"))
.Open PathOnly
End With
'4b)
Let txt = Mid$(txt, 6) ' (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
Dim Rs As Object: Set Rs = CreateObject("ADODB.Recordset")
Rs.Open "Select * From [tempComma.csv] Where " & txt, Cn, 3
Dim x As String
Let x = Rs.GetString(, , ",", vbCrLf): Debug.Print x
Set Cn = Nothing: Set Rs = Nothing
Rem 5
Kill fn
Rem 6
Open Replace(myCSV, ".csv", "_Filtered.csv") For Output As #1
Print #1, x;
Close #1
End Sub
In suppot of this forum post
https://excelfox.com/forum/showthrea...sx-to-txt-file
https://www.excelfox.com/forum/showt...ge30#post13348
Code:' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add After:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop========================================================================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
Case ","
Let WotchaGot = WotchaGot & """" & "," & """" & " & "
Case ";"
Let WotchaGot = WotchaGot & """" & ";" & """" & " & "
Case ":"
Let WotchaGot = WotchaGot & """" & ":" & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop=================================================================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Let Ws1.Range("A1").Value = strIn
Let Ws1.Range("B1").Value = WotchaGot
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
Ws.Activate: Ws.Cells.Item(1, 1).Activate
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
End Sub
'
lKSHFLhlhfl
lKSHFLhlhfl
lKSHFLhlhfl
So my solution, which I will give in the next post will solve this problem, which is your problem shortened.
_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col
Case1
If I paste or enter A in cell C3, then, automatically put the value…
BOY in cell D3, GEN in cell E3 and URBAN in cell F3
Similarly,
If I paste or enter B in cell C3, then, automatically put the value…
BOY in cell D3, OBC in cell E3 and URBAN in cell F3
Similarly,
As shown in REFERENCE CHART)
the corresponding value should filled in the corresponding cells automatically
Now,
Similarly,
same condition is applied to cell C4, C5, C6 and so on
that is,
If I paste or enter A in cell C4, then, automatically put the value…
BOY in cell D4, GEN in cell E4 and URBAN in cell F4
_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col
Case2
If I paste or enter BOY in cell D3, GEN in cell E3 and URBAN in cell F3
then, automatically put the value A in cell C3
Similarly,
If I paste or enter BOY in cell D3, OBC in cell E3 and URBAN in cell F3
then, automatically put the value B in cell C3
post to get link for later use...
test
“Moderator” Notice
**I am Banning you to prevent you making any more postings here of the type you have been making here and elsewhere under hundreds of different user names at many of the English speaking Excel and Office help forums for the last couple of years.
The type of post that you have been posting suggest that
_ You may be one person or a !!team of many people working at something organised like a Call Centre.
( !! Sometime when you have been “caught” cross posting, you did not know yourself where you cross posted, and asked to be told. ( Or you maybe only wanted to admit to those where you got “caught”) )
_ You have almost no understanding of the English language
_ You may not have a computer and may have no access to Excel
_ You have no interest in Excel or Excel VBA
_ You have almost no knowledge or interest in any of the questions that you are asking
_ You may be simply offering a service of posting other peoples questions and supplying them with any answers you get.
_ You may be part of the development of a question asking and Replying Bot
_ In some cases, something extremely simple to understand, has been explained to you very many times, in great detail , even graphically, such that even a small mentally handicapped child could understand it and remember it. Despite this, you continually ask exactly that same question over and over again: If you are part of a team interested in only posting questions and taking the answer, then you are very badly organised,
Or
There is no real intelligence behind what is producing your questions and posts
_ One of the things you consistently do after receiving a macro is to delete all explanations, explaining 'comments and all files associated, and indeed it appears as if you try to remove almost all record of the coding and the question and answer. This further encourages the posting of the same or similar questions over and over again.
Whatever you are attempting to do, it appears to be extremely, almost insanely, inefficient ,
compared to
a single person with a computer and Excel, and a minimum of basic Excel VBA knowledge trying to achieve the same.
The main reason for the ban is
Whatever you are attempting to do, it is requiring 10-100 times more time than is typically required of helpers at a forum. All indications are that what you are doing will fail to achieve anything, and is therefore a total waste of everyone’s time. At excelfox, the current small number of helpers have only a limited amount of time, but even if we had more members, excelfox would not be the place for you## Some of the major forums may be a good place for you to post.
These are some suggestions, from me, on how you should continue
_ If you intend to continue, regardless of any of my previous suggestions, in postings of the type as you have done in the past, then you should think about making some changes to your wording, introduce some new canned replies, possibly organise a new set of similar questions and post at the major forums, such as mrexcel.com, excelforum.com, ozgrid.com
_ If you wish to make a career out of posting questions and getting answers without having any real intentions of thinking about anything, then excelfox is not the forum for you to post in. Most of the smaller forums are not the place for you. The larger forums may be able to accommodate you, if you give at least some thought to making it not quite so obvious: Your distinguishing characteristic is that you have been making it much more obvious than others doing the same, do: Many people do the such. At least half the traffic at such forums originates from such. I have passed many people on to such forums and they are making a successful career based on passing on the work done for them by helpers at the major forums. Such is actually encouraged, all be it , not openly, at the major forums.
_ If you have not understood most of this Moderator Notice , then your first priority should be to improve on your English. Indeed, your apparent understanding and ability in communicating in English suggests that you will achieve nothing whatsoever and fail completely in anything at all involving communicating in English.
_ If you are, as you sometimes told me via PM, actively working on an important personal problem requiring VBA , then you are doing it totally wrongly: You have been on the project already for at least two years and have a mixed up set of codings produced by many different people. Some work . Some don’t. You have not the slightest idea or understanding of any of the codings. You will never be able to use them to any effect. If , on the other hand, you had a computer, with Excel, and spent a few weeks learning VBA, and then carefully studied all the macros that you have been given, then you would be able to answer most of your further questions, and would have at least a chance of being able to use the codings effectively:-
1 Month learn VBA and 1 month getting answers, partly alone, partly with help from forums = Finished Success
2+ Years posting the same and similar questions and just taking the answers = Never Ending Fail
_ It is unlikely that the macros you have that work will ever be very efficient and will likely be slower than anyone else’s: They will certainly not be the best possible. Giving you better coding has proved to be impossible: It is not possible to pass on better codings because of the ridiculously inefficient way that you are organising whatever it is that you are doing: The person receiving and passing on the coding needs to understand the English language and to understand some basic coding and to understand how to use such better coding. We have tried this a few times, but it proved always completely impossible to do. One example of this is the issue of text files: Because you are mostly dealing with values, the use of text files is almost certainly beneficial and in some cases the only efficient way to proceed. You have completely missed the point on this: You have repeated much work to try to avoid using text files. The problem was, and will never be, the issue of text files themselves. The issue is your total inability or unwillingness to understand anything at all about them.
##The main purpose of the question section of excelfox is approximately the following:
_1. Promote and improve the understanding of Excel and Excel VBA.
_2. Help people who get stuck on a problem and/or help people who are unsure how to proceed in solving a problem using Excel and Excel VBA.
Your objectives??
I do not know what the true reason is behind your postings. I can’t believe anything you say is your purpose, since you have lied and contradicted yourself in the past. The only thing we know 100% for sure is that your posting types are not for any of the purposes for which the question section of excelfox is intended.
You have had the benefit of the doubt given to you now very many times. You have had lots of chances.
You may be able to continue at some of the major forums, where some people are happy to continue to spend time to answer similar questions from the same source.
I do not think you will get any more replies to the types of postings you have been making at excelfox or at any other of the smaller English speaking Forums. You are wasting your time making any such posts from now on.
**I am Banning you, not as any form of punishment, but purely as in the past , it has proven to be the only way to prevent you wasting yours and other peoples time with your postings.
I do wish you luck and success with what ever it is you are attempting to do. But you should not be doing it at excelfox.
If you are attempting the personal project that you have told me about via PM, then you are going about it in completely the wrong way.
If you are trying to make a career of posting other people’s questions and getting answers for them, then you should post mostly at the major forums and organise yourself better: At least have access to Excel on a computer and learn the basics of VBA. If you are trying to make a career of posting other people’s questions and getting answers for them, as many people do, then you have made the mistake of making it too obvious. Many of the senior helpers at the main forums prefer to think that they are helping people rather than doing their work for them. What they don’t know, does not hurt them. :)
I will leave all your posts in the main forum for a few weeks. Then I will move them all to the test forum. I will probably further merge them. Eventually I may delete them all.
Bro, whatever you are trying to do, its not working. Its never going to work. Its just wasting everybody’s time.
You need first to learn English
Then get a computer.
Then learn some basic Excel and Excel VBA
Then start again.
I have not been so impressed with my flower efforts this Summer. I will give Petra the blame for that: Do you remember my great success with the Sun Flowers in the wheelbarrow (https://imgur.com/hF1B4I1 )
Well Petra was not so impressed, she didn’t think it was so nice a wheelbarrow exploding with Sun Flowers, so as a compromise we said we would do it every other year.
But at the end of last year I must have got a few hundred seeds from the flowers. I planted about 100 of them all over the place at the start this year.
It was not a great success, possibly because we have so much shade, almost everywhere. I only noticed 3 growing, 2 still have not got very far. But a combination of intelligence and some nice late Summer sun has got the one up and he is letting everyone see him ….. first it grew about 80cm vertically to get out of the shade, then when it got out in the open it shot up.
https://imgur.com/IRW78eD
https://imgur.com/xKSfRU9
The clever Sun Flower. I must make a point of saving his seeds. ….
Macro for this post
https://excelfox.com/forum/showthrea...ll=1#post14572
_ 4.
This is easy, simply convert the Target.Value to UCase(Target.Value) , and use that converted character in place of Target.Value
( If the Target.Value is already uppercase, then UCase(Target.Value) will not error - Target.Value will just stay as it is )
_ 2. And 3.
This is not difficult, but need s some juggling around with code lines
Two similar code sections are needed
_1. This is a bit more difficult. It is rather unusual not to have a range of the required LookUp information somewhere
This information must come from somewhere.
The most simple solution would be to have that range somewhere
For now , I have put the information on a second worksheet. And made a minor change to the macro to reference that worksheet
If this is not acceptable, then I can put the information somewhere else, such as in the macro itself.
So here is my next solution for you.
Once again for now, for clarity and simplicity, I have limited it just to a few rows
Code:Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Bed
If Application.Intersect(Target, Me.Range("C3:F5")) Is Nothing Then Exit Sub ' No overlap with the entry range, so exit sub
' Case1
If Not Application.Intersect(Target, Me.Range("C3:C5")) Is Nothing Then ' Column C entry
If IsArray(Target.Value) Then Exit Sub ' more than one cell selected, but this procedure can only work on single cell entries in column C
If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Target.Offset(0, 1).Resize(1, 3).Value = "" ' If I delete the Alpha Code from a cell (for example C3), the corresponding range (D3:F3) should be empty/deleted automatically.
Let Application.EnableEvents = True
ElseIf Len(Target.Value) <> 1 Then Exit Sub ' we have an entry , but it is invalid
Else
End If
Dim UcsTgtVl As String: Let UcsTgtVl = UCase(Target.Value)
If InStr(1, ",A,B,C,D,E,", "," & UcsTgtVl & ",", vbBinaryCompare) = 0 Then Exit Sub
Dim PosS As Long: Let PosS = (InStr(1, ",A,B,C,D,E,", UcsTgtVl, vbBinaryCompare) / 2) + 2 ' Row number in REFERENCE CHART for the corrsponding Sex Category Area values
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Target.Offset(0, 1).Resize(1, 3).Value = ThisWorkbook.Worksheets("REFERENCE CHART").Range("T" & PosS & ":V" & PosS & "").Value
Let Application.EnableEvents = True
' Case2
ElseIf Not Application.Intersect(Target, Me.Range("D3:F5")) Is Nothing Then ' Entry in column D E or F
If Target.Columns.Count = 1 Then
If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Me.Range("C" & Target.Row & "").Value = "" ' If I delete any one cell value from the range (for example D3:F3), the corresponding Alpha Code (C3) should be deleted automatically. It means, the Alpha Code should be appear only if all the three cells in the corresponding range (for example D3:F3) are filled. Otherwise, the Alpha Code should be disappear/deleted.
Let Application.EnableEvents = True
Exit Sub
Else
End If
ElseIf Target.Rows.Count <> 1 Then Exit Sub ' more than 1 row selected, but this procedure can only work on single row entries
Else
End If
Dim arrSCA() As Variant: Let arrSCA() = Array("BOYGENURBAN", "BOYOBCURBAN", "BOYSCURBAN", "BOYSTURBAN", "GIRLGENURBAN")
Dim TrgtRw As Long: Let TrgtRw = Target.Row
Dim DEF As String: Let DEF = Me.Range("D" & TrgtRw).Value & Me.Range("E" & TrgtRw).Value & Me.Range("F" & TrgtRw).Value
Dim Mtchres As Variant
Let Mtchres = Application.Match(DEF, arrSCA, 0)
If IsError(Mtchres) Then Exit Sub ' no matching set of entries in columns D E and F
Dim PosS2 As Long: Let PosS2 = Mtchres + 2 ' Row number in REFERENCE CHART for the corresponding Alpha Code
Let Application.EnableEvents = False
Let Me.Range("C" & TrgtRw & "").Value = Me.Range("S" & PosS2 & "").Value
Let Application.EnableEvents = True
Else
End If
Bed: ' just incase anything goes wrong, it is a good idea to make sure that things are turned back to normal
Let Application.EnableEvents = True
End Sub
Share ‘Autofill.xlsm’ : https://app.box.com/s/mt1c2xvdejjj6d3vjo6wkjyrdxrs98tm
Post for later use
“Moderator” Notice
**I am Banning you to prevent you making any more postings here of the type you have been making here and elsewhere under hundreds of different user names at many of the English speaking Excel and Office help forums for the last couple of years.
The type of post that you have been posting suggest that
_ You may be one person or a !!team of many people working at something organised like a Call Centre.
( !! Sometime when you have been “caught” cross posting, you did not know yourself where you cross posted, and asked to be told. ( Or you maybe only wanted to admit to those where you got “caught”) )
_ You have almost no understanding of the English language
_ You may not have a computer and may have no access to Excel
_ You have no interest in Excel or Excel VBA
_ You have almost no knowledge or interest in any of the questions that you are asking
_ You may be simply offering a service of posting other peoples questions and supplying them with any answers you get.
_ You may be part of the development of a question asking and Replying Bot
_ In some cases, something extremely simple to understand, has been explained to you in great detail , even graphically, such that even a small mentally handicapped child could understand it and remember it. Despite this, you continually ask exactly that same question over and over again: If you are part of a team interested in only posting questions and taking the answer, then you are very badly organised,
Or
There is no real intelligence behind what is producing your questions and posts
_ One of the things you consistently do after receiving a macro is to delete all explanations, explaining 'comments and all files associated, and indeed it appears as if you try to remove almost all record of the coding and the question and answer. This further encourages the posting of the same or similar questions over and over again.
Whatever you are attempting to do, it appears to be extremely, almost insanely, inefficient ,
compared to
a single person with a computer and Excel, and a minimum of basic Excel VBA knowledge trying to achieve the same.
The main reason for the ban is
Whatever you are attempting to do, it is requiring 10-100 times more time than is typically required of helpers at a forum. All indications are that what you are doing will fail to achieve anything, and is therefore a total waste of everyone’s time. At excelfox, the current small number of helpers have only a limited amount of time, but even if we had more members, excelfox would not be the place for you## Some of the major forums may be a good place for you to post.
These are some suggestions, from me, on how you should continue
_ If you intend to continue, regardless of any of my previous suggestions, in postings of the type as you have done in the past, then you should think about making some changes to your wording, introduce some new canned replies, possibly organise a new set of similar questions and post at the major forums, such as mrexcel.com, excelforum.com, ozgrid.com
_ If you wish to make a career out of posting questions and getting answers with out having any real intentions of thinking about anything, then excelfox is not the forum for you to post in. Most of the smaller forums are not the place for you. The larger forums may be able to accommodate you, if you give at least some thought to making it not quite so obvious: Your distinguishing characteristic is that ylou have been making it much more obvious than others doing the same, do: Many people do the such. At least half the traffic at such forums originates from such. I have passed many people on to such forums and they are making a successful career based on passing on the work done for them by helpers at the major forums. Such is actually encouraged, all be it , not openly, at the major forums.
_ If you have not understood most of this Moderator Notice , then your first priority should be to improve on your English. Indeed, your apparent understanding and ability in communicating in English suggests that you will achieve nothing whatsoever and fail completely in anything at all involving communicating in English.
_ If you are, as you sometimes told me via PM, actively working on an important personal problem requiring VBA , then you are doing it totally wrongly: You have been on the project already for at least two years and have a mixed up set of codings produced by many different people. Some work . Some don’t. You have not the slightest idea or understanding of any of the codings. You will never be able to use them to any effect. If , on the other hand, you had a computer, with Excel, and spent a few weeks learning VBA, and then carefully studied all the macros that you have been given, then you would be able to answer most of your further questions, and would have at least a chance of being able to use the codings effectively:-
1 Month learn VBA – 1 month getting answers, partly alone, partly with help from forums = Finished Success
2+ Years posting almost the same questions and just taking the answers = Never Ending Fail
##The main purpose of the question section of excelfox is approximately the following:
_1. Promote and improve the understanding of Excel and Excel VBA.
_2. Help people who get stuck on a problem and/or help people who are unsure how to proceed in solving a problem using Excel and Excel VBA.
Your objectives??
I do not know what the true reason is behind your postings. I can’t believe anything you say is your purpose, since you have lied and contradicted yourself in the past. The only thing we know 100% for sure is that your posting types are not for any of the purposes for which the question section of excelfox is intended.
You have had the benefit of the doubt given to you now very many times. You have had lots of chances.
You may be able to continue at some of the major forums, where some people are happy to continue to spend time to answer similar questions from the same source.
I do not think you will get any more replies to the types of postings you have been making at excelfox or at any other of the smaller English speaking Forums. You are wasting your time making any such posts from now on.
**I am Banning you, not as any form of punishment, but purely as in the past , it has proven to be the only way to prevent you wasting yours and other peoples time with your postings.
I do wish you luck and success with what ever it is you are attempting to do. But you should not be doing it at excelfox.
If you are attempting the personal project that you have told me about via PM, then you are going about it in completely the wrong way.
If you are trying to make a career of posting other people’s questions and getting answers for them, then you should post mostly at the major forums and organise yourself better: At least have access to Excel on a computer and learn the basics of VBA. If you are trying to make a career of posting other people’s questions and getting answers for them, as many people do, then you have made the mistake of making it too obvious. Many of the senior helpers at the main forums prefer to think that they are helping people rather than doing their work for them. What they don’t know, does not hurt them. :)
Post for later use _
Worked example for this Thread
https://excelfox.com/forum/showthrea...sult-is-change
Before: as supplied by OP
_____ Workbook: help0824.xls ( Using Excel 2007 32 bit )
Worksheet: Sheet2
Row\Col A B C D E F G H I J K 15 ITEM DESCRIPTION QTY UNIT UNIT PRICE TOTAL AMOUNT REMARKS 16 1 3 30 90 17 18 2 20 1.5 30 19 3 4 55 220 20 21 4 1 250 250 22 23 24 25 26 27 28 29 30 31 32 33 34 35 Total 7 310.00
After
The macro is an events coding macro so it starts automatically,
....For example, I do the given example... ....'Example:
'Suppose the user fills in 3 in Cell G20, user fills in 15.25 in Cell I20 ,
'the serial number of Cell A20 serial number will automatic become 4,
' and the original 4 of cell A21 will automatically become 5
'
'At this time, G35 original is 7 , will automatically calculates 10,
' J20 automatically calculates 45.75
'At this time, J35 original is 310 , will automatically calculates 355.75
_____ Workbook: help0824.xls ( Using Excel 2007 32 bit )
Worksheet: Sheet2
Row\Col A B C D E F G H I J K 15 ITEM DESCRIPTION QTY UNIT UNIT PRICE TOTAL AMOUNT REMARKS 16 1 3 30 90 17 18 2 20 1.5 30 19 3 4 55 220 20 4 3 15.25 45.75 21 5 1 250 250 22 23 24 25 26 27 28 29 30 31 32 33 34 35 Total 10 355.75
Macro for last post, and for answer to this Thread
https://excelfox.com/forum/showthrea...ll=1#post14831
Code:Public Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
' get current maximum item number info: wjat is it, and where is it
Dim Cnt As Long, Mx As Long, MxInd As Long ' MxInd is for the Item number at which we got the maximum , - I need this to know where to put the new ITEM
Dim RngA As Range: Set RngA = Range("A16:A34")
For Cnt = 1 To RngA.Rows.Count Step 1
If Mx < RngA.Item(Cnt).Value Then ' In Excel Ranges cell item numbers are counted along columns then next rows etc. So for a single column, each next item number is the next row
Let Mx = RngA.Item(Cnt).Value
Let MxInd = Cnt
Else
End If
Next Cnt
' update current row item number to be the current highest, and make previous highest one more
Let Application.EnableEvents = False ' I have to temporarily turn this thing off, or else the next line makes this macro start again
Let Range("A" & Target.Row & "").Value2 = Mx: Let RngA.Item(MxInd).Value2 = Mx + 1
Let Application.EnableEvents = True
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim RngJ As Range: Set RngJ = Range("J16:J34")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If RngG.Item(Cnt).Font.Strikethrough = False And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If RngJ.Item(Cnt).Font.Strikethrough = False And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G35").Value2 = SumG: Let Range("J35").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub
Second solution for this Thread
https://excelfox.com/forum/showthrea...sult-is-change
Looking at jindon’s solution at the cross post:
https://www.excelforum.com/excel-pro...is-change.html
Jindon has done a function to do the summing of the columns G and J
He sugest that, for example you place then in cell J35
=SumIfClear(J16:J34) https://www.excelforum.com/excel-pro...ml#post5386274
What this does is , taken in the column range, rng , and return the sum value as required.
It does it like this:
' make a range object , x , of a few areas, each area being a row with a “shape with a name Like "Line*"
' The sum calculation is then done only taking row values in the column, range , rng , which do not intersect with the range of rows with a shape, x
Code:Option Explicit
' https://www.excelforum.com/excel-programming-vba-macros/1325405-reserve-the-horizontal-line-numbers-and-information-but-the-calculation-result-is-change.html
Sub CallSumIfClear()
Call SumIfClear(Range("J16:J34"))
End Sub
Function SumIfClear(rng As Range) As Double
Dim r As Range, x As Range, Sp As Shape
'Application.Volatile
' make a range object of a few areas, each area being a row with a shape with a name Like "Line*"
For Each Sp In rng.Worksheet.Shapes
If Sp.Name Like "Line*" Then
If x Is Nothing Then
Set x = Range(Sp.TopLeftCell, Sp.BottomRightCell)
Else
Set x = Union(x, Range(Sp.TopLeftCell, Sp.BottomRightCell))
End If
End If
Next
' The sum calculation
For Each r In rng
If Intersect(r, x) Is Nothing Then SumIfClear = SumIfClear + Val(r.Value)
Next
End Function
( The formula given by Jindon is no good as it does not answer the question )
Jindon’s formula has shown me how to determine where shapes ( like a line ) are.
So I could, for example, build a string of the row numbers with a shape in
For example this next macro , will return, for the sample data, in the variable, strLnRws ,
__18__21__
Code:Sub BuildStingOfRowsWithShapeLine()
Dim strLnRws As String: Let strLnRws = " "
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Debug.Print strLnRws ' From VB Editor , hit keys Ctrl + g to get the immediate window to see the contents
End Sub
I can check for the rows so as not to sum those rows. ( Note I will check for a string of “ “ & TheRowNumber & “ “ , as this will avoid errors caused by checking for , for example 3 , when I have a row of 436 : If I checked for 3 , I would find it if I had 436 , which would be incorrect )
For example, the Instr function can be used to see if a row number is present in that strLnRws. Thuis is implimented in the example below to get the sum for column G
Code:Sub BuildStingOfRowsWithShapeLineAndSumColumnIfNoShapeLine()
Dim strLnRws As String: Let strLnRws = " "
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Debug.Print strLnRws ' From VB Editor , hit keys Ctrl + g to get the immediate window to see the contents
Dim Cnt
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then ' InStr will return a 0 if the rows number is not present in the string strLnRws
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Debug.Print SumG
End Sub
Using the above information we can write a second event coding macro which this time will work on the original worksheet: there is no longer a need to modify the range to have strikethroughs:
See next post
Macro for last post, and for second answer to this Thread
https://excelfox.com/forum/showthrea...ll=1#post14831
Code:Public Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
' get current maximum item number info: wjat is it, and where is it
Dim Cnt As Long, Mx As Long, MxInd As Long ' MxInd is for the Item number at which we got the maximum , - I need this to know where to put the new ITEM
Dim RngA As Range: Set RngA = Range("A16:A34")
For Cnt = 1 To RngA.Rows.Count Step 1
If Mx < RngA.Item(Cnt).Value Then ' In Excel Ranges cell item numbers are counted along columns then next rows etc. So for a single column, each next item number is the next row
Let Mx = RngA.Item(Cnt).Value
Let MxInd = Cnt
Else
End If
Next Cnt
' update current row item number to be the current highest, and make previous highest one more
Let Application.EnableEvents = False ' I have to temporarily turn this thing off, or else the next line makes this macro start again
Let Range("A" & Target.Row & "").Value2 = Mx: Let RngA.Item(MxInd).Value2 = Mx + 1
Let Application.EnableEvents = True
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G34")
' Build Sting Of Rows With Shape Line And Sum Column If No Shape Line https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)-Event-Coding?p=14844&viewfull=1#post14844
Dim strLnRws As String: Let strLnRws = " "
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Dim RngJ As Range: Set RngJ = Range("J16:J34")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If InStr(1, strLnRws, " " & RngJ.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G35").Value2 = SumG: Let Range("J35").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub
I have put this in the worksheet object code module of worksheet "Sheet2 excelforum jindon" in the uploaded file: -
help0824.xls : https://app.box.com/s/fkfuld8yk4xrna5vt069x75intiyzs8i
Macro for this post
https://excelfox.com/forum/showthrea...ll=1#post14848
In ThisWorkbook code module
In third worksheets object code moduleCode:Option Explicit
Private Sub Workbook_Open()
Let Sheet3.UsdRws = Worksheets.Item(3).UsedRange.Rows.Count
End Sub
Code:Option Explicit
Public UsdRws As Long
Public Sub Worksheet_Change(ByVal Target As Range)
If Me.UsedRange.Rows.Count = UsdRws + 1 Then ' We added a row
Let Application.EnableEvents = False
Let Range("J" & Target.Row & "").Value = "=IF(OR(RC[-3]="""",RC[-1]=""""),"""",RC[-3]*RC[-1])"
Let Application.EnableEvents = True
Let UsdRws = UsdRws + 1
Exit Sub ' No more will be done after a row insert
Else
End If
If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest Note: this would also be set off by a row insertion, but we will not let it because we exited before
' Dynamic Lr
Dim Lr As Long: Let Lr = Range("J" & Rows.Count & "").End(xlUp).Row - 1
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
Let Application.EnableEvents = False
Let Range("A" & Target.Row & "").Value2 = "anything" ' Put anything in for now
Let Application.EnableEvents = True
Dim RngA As Range: Set RngA = Range("A16:A" & Lr & "")
Dim Cnt As Long, ACel As Range
For Each ACel In RngA.SpecialCells(xlCellTypeConstants) ' Each cell with something in it in column A
Let Cnt = Cnt + 1
Let Application.EnableEvents = False
Let ACel.Value = Cnt ' The next cell down is given the next number
Let Application.EnableEvents = True
Next ACel
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G" & Lr & "")
' Build Sting Of Rows With Shape Line And Sum Column If No Shape Line https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)-Event-Coding?p=14844&viewfull=1#post14844
Dim strLnRws As String: Let strLnRws = " "
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Dim RngJ As Range: Set RngJ = Range("J16:J" & Lr & "")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If InStr(1, strLnRws, " " & RngJ.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G" & Lr + 1 & "").Value2 = SumG: Let Range("J" & Lr + 1 & "").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub
In support of this Thread answer
List table supplied by OP in uploade file
_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB 15 (Select Here) 16 Nuclear Family (Remark if any) 17 Joint Family (Remark if any) 18 Single-Parent Family (Select Reason) 19 Expired 20 Divorced 21 Break-Up 22 Abandonment 23 Enter Reason Manually 24 Joint Family (Please Specify the Case)
I am not sure why get those strange black areas , so I did a find on [td=bgcolor:#000000] replacing withnothing
_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB 15 16 17 18 19 20 21 22 23 24
So I did a find on [td=bgcolor:#000000] replacing with [td]
_....see next post
_... from last post
_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB 15 (Select Here) 16 Nuclear Family (Remark if any) 17 Joint Family (Remark if any) 18 Single-Parent Family (Select Reason) 19 Expired 20 Divorced 21 Break-Up 22 Abandonment 23 Enter Reason Manually 24 Joint Family (Please Specify the Case)
Some Immediate window results
? Range("AM15").font.ThemeColor
7
? Range("AM15").font.TintAndShade
0
? Range("AM15").font.Color
10855845
? Range("AM15").font.Colorindex
48
? Range("AM16").font.tintandshade
0
? Range("AM16").font.Bold
Falsch
? Range("AM16").font.Color
6751362
? Range("AM16").font.Colorindex
13
? Range("AM16").font.Bold
Falsch
? Range("AT19").Font.Tintandshade
0
? Range("AT19").Font.Color
0
? Range("AT19").Font.colorindex
-4105
? Range("AT19").Font.Bold
Falsch
Just testing in this post.....
_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB 16 (Select Here) 16 Nuclear Family (Remark if any) 17 Joint Family (Remark if any) 18 Single-Parent Family (Select Reason) 19 Expired 20 Divorced 21 Break-Up 22 Abandonment 23 Enter Reason Manually 24 Joint Family (Please Specify the Case)
Solution for ( part A) ) of this Thread
https://excelfox.com/forum/showthrea...ll=1#post14870
Code:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$J$19" Then
If Target.Value = "" Then
Let Application.EnableEvents = False
Let Target.Value = "(Select)"
Let Application.EnableEvents = True
With Target.Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Nuclear Family" Or Target.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
End If
Else
' Target is Not a cell to be acted on
End If
End Sub
'Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB
'16 (Select Here)
'16 Nuclear Family (Remark if any)
'17 Joint Family (Remark if any)
'18 Single-Parent Family (Select Reason)
'19 Expired
'20 Divorced
'21 Break -Up
'22 Abandonment
'23 Enter Reason Manually
'24 Joint Family (Please Specify the Case)
'Print Range("AM15").Font.ThemeColor
'7
'Print Range("AM15").Font.TintAndShade
'0
'Print Range("AM15").Font.Color
'10855845
'Print Range("AM15").Font.ColorIndex
'48
'Print Range("AM16").Font.TintAndShade
'0
'Print Range("AM16").Font.Bold
'Falsch
'Print Range("AM16").Font.Color
'6751362
'Print Range("AM16").Font.ColorIndex
'13
'Print Range("AM16").Font.Bold
'Falsch
'Print Range("AT19").Font.TintAndShade
'0
'Print Range("AT19").Font.Color
'0
'Print Range("AT19").Font.ColorIndex
'-4105
'Print Range("AT19").Font.Bold
'Falsch
Answer to this Thread post:
https://excelfox.com/forum/showthrea...ll=1#post14873
Code:Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If
Else
' Target is Not a cell to be acted on
End If
If Target.Address = "$R$19" Then Let Target.Font.ColorIndex = xlAutomatic
End Sub
In support of this püost:
https://excelfox.com/forum/showthrea...ll=1#post14877
Code:Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Range("R19").Value = ""
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
' Range("R19:Z19").Select
' With Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlCenter
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
' End With
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
' The drop down validation list in cell R19 is produced when the value "Single-Parent Family" is selected in cell J19
' Range("R19").Select
With Range("R19").Validation 'With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Expired,Divorced,Break-Up,Abandonment,Enter Reason Manually"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Error!"
.InputMessage = ""
.ErrorMessage = "To enter the reason manually, please select the option 'Enter Reason Manually'"
.ShowInput = True
.ShowError = True
End With
ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If ' end of all values of J19 to result in actions
Else
' Target is not cell J19 ( or J19:P19 )
End If
' If Target.Address = "$R$19" Then Let Target.Font.ColorIndex = xlAutomatic
'
' If Target.Address = "$J$19" Then
' If Target.Value = "Single-Parent Family" Then
' Let Application.EnableEvents = False
' Let Range("R19").Value = "Select Reason..."
' Let Application.EnableEvents = True
' With Range("R19").Font
' .Color = -10477568
' .TintAndShade = 0
' End With
'' Target.Font.Size = 11.5
'
' End If
' If drop down list is present in cell R19 , and "Enter Reason Manually" is selected from that drop down list in R19, then the drop down validation list in cell R19 is removed.
If Target.Address = "$R$19" Then
Let Target.Font.ColorIndex = xlAutomatic
If Target.Value = "Enter Reason Manually" Then
' With Target.Validation ' Selection.Validation
' .Delete
Target.Validation.Delete
' .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
' :=xlBetween
' .IgnoreBlank = True
' .InCellDropdown = True
' .ShowInput = True
' .ShowError = True
' End With
' Selection.ClearContents
' With Target.Font
' .ThemeColor = xlThemeColorLight1
' .TintAndShade = 0
' End With
' Range("R19:Z19").Select
' With Selection
' .HorizontalAlignment = xlLeft
' .VerticalAlignment = xlCenter
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
' End With
' Target.Font.Size = 11.5
End If
Else
' Target is not R19
End If
End Sub
Code:Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Range("R19").Value = ""
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
' The drop down validation list in cell R19 is produced when the value "Single-Parent Family" is selected in cell J19
With Range("R19").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Expired,Divorced,Break-Up,Abandonment,Enter Reason Manually"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Error!"
.InputMessage = ""
.ErrorMessage = "To enter the reason manually, please select the option 'Enter Reason Manually'"
.ShowInput = True
.ShowError = True
End With
ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If ' end of all values of J19 to result in actions
Else
' Target is not cell J19 ( or J19:P19 )
End If
' If drop down list is present in cell R19 , and "Enter Reason Manually" is selected from that drop down list in R19, then the drop down validation list in cell R19 is removed.
If Target.Address = "$R$19" Then
Let Target.Font.ColorIndex = xlAutomatic
If Target.Value = "Enter Reason Manually" Then
Target.Validation.Delete
Else
End If
Else
' Target is not R19
End If
End Sub
First macro for this Post:
https://excelfox.com/forum/showthrea...4913#post14913
Code:Sub TestieCalls()
Call Me.Worksheet_Change(Me.Range("B4"))
End Sub
Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As Long
Let Lr = Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = Me.Cells(4, 2).End(xlToRight).Column ' I am using a slightly less common way including xlToRight because there are some explanation wordings that would be found giving a false number by the more typically used Columns.Count xlToLeft way
Dim RngTbl As Range: Set RngTbl = Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem Loop
Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim Cnt
For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
Dim Clm As Long: Let Clm = 2 ' "column" in table array
Dim Decs As Long
'For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
Do
If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then ' we no longer have a decresing sequence
Let Decs = 0 ' Reset the count of sequential decreasing values
Else ' we have at least 2 sequential decreses, possibly 3
Let Decs = Decs + 1
End If
'Next Clm
Let Clm = Clm + 1
Loop While Clm < UBound(arrTbl(), 2) And Decs < 2
'If Clm = UBound(arrTbl(), 2) Then ' this will occur if we did not exit the For loop
If Decs = 2 Then ' If decs = 2 we had three seqeuntial decreses = sequentially 2 x arrTbl(Cnt, Clm + 1) < arrTbl(Cnt, Clm)
Dim StrRemmark As String
Let StrRemmark = StrRemmark & " and " & arrTbl(Cnt, 1)
Else
End If
Let Decs = 0 ' reset the count of sequential decreasing values so that Decs can be used in the next main row loop
Next Cnt
End If
' add remark
If StrRemmark <> "" Then
Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
Final macro for this post
https://excelfox.com/forum/showthrea...4913#post14913
Code:' https://excelfox.com/forum/showthread.php/2633-Showing-Custom-Value-Based-on-the-Condition-of-Dynamic-Table?p=14913&viewfull=1#post14913
'Important:
' All of the above conditions are applied only if there are minimum 3 consecutive cells which are in descending order.
' For example, cells D5, E5 and F5 have values which are satisfied all the three condition, i.e, they are in descending order, and they are consecutive (side by side), and they are minimum three.
'
'Point 1) Missing comma: When all the three rows contains values in descending order, then B4 shows -
' Student is decreasing in ENGLISH and HINDI and MATHS
' It should be - Student is decreasing in ENGLISH, HINDI and MATHS (as we normally write in English language)
Sub TestieCalls()
Call Me.Worksheet_Change(Me.Range("B4"))
End Sub
Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As Long
Let Lr = Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = Me.Cells(4, 2).End(xlToRight).Column ' I am using a slightly less common way including xlToRight because there are some explanation wordings that would be found giving a false number by the more typically used Columns.Count xlToLeft way
Dim RngTbl As Range: Set RngTbl = Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem Loop
Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim Cnt
For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
Dim Clm As Long: Let Clm = 2 ' "column" in table array
Dim Decs As Long
'For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
Do
If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then ' we no longer have a decresing sequence
Let Decs = 0 ' Reset the count of sequential decreasing values
Else ' we have at least 2 sequential decreses, possibly 3
Let Decs = Decs + 1
End If
'Next Clm
Let Clm = Clm + 1
Loop While Clm < UBound(arrTbl(), 2) And Decs < 2
'If Clm = UBound(arrTbl(), 2) Then ' this will occur if we did not exit the For loop
If Decs = 2 Then ' If decs = 2 we had three seqeuntial decreses = sequentially 2 x arrTbl(Cnt, Clm + 1) < arrTbl(Cnt, Clm)
Dim StrRemmark As String
'Let StrRemmark = StrRemmark & " and " & arrTbl(Cnt, 1)
'Let StrRemmark = StrRemmark & ", " & arrTbl(Cnt, 1)
Let StrRemmark = StrRemmark & ", " & Left(arrTbl(Cnt, 1), 1) & Mid(LCase(arrTbl(Cnt, 1)), 2) ' This effectively changes something like MATHS to M & aths = Maths
Else
End If
Let Decs = 0 ' reset the count of sequential decreasing values so that Decs can be used in the next main row loop
Next Cnt
End If
' add remark
If StrRemmark <> "" Then
'Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let StrRemmark = Mid(StrRemmark, 3) ' this takes off the first ", "
Dim Pos As Long: Let Pos = InStrRev(StrRemmark, ", ", -1, vbBinaryCompare)
If Pos <> 0 Then ' Pos will be 0 if no ", " was found
Let StrRemmark = Application.WorksheetFunction.Replace(StrRemmark, Pos, 2, " and ") ' _3 WorksheetFunction.Replace Method https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Else
' we had no ", " in the final string , so we just have one subject
End If
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark & "."
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
macro solution for this post:
https://excelfox.com/forum/showthrea...ll=1#post14955
Code:Sub Testie() ' For testing in pre Office 2016
Call Me.Worksheet_Change(Me.Range("K74")) ' this simulates a change in cell K74
End Sub
Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As String ' Lc As Long
Let Lr = 81 ' Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = "S"
Dim RngTbl As Range ' : Set RngTbl = Me.Range("K74:" & Lc & Lr & "")
'or simply
Set RngTbl = Me.Range("K74:S81") ' Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("H40").Value = "No Remarks" ' Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem We now get the array , arrDec() , directly from X74:X81
'Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim arrDec() As Variant ' As Boolean: ReDim arrDec(1 To Lr - 3)
Let arrDec() = Me.Range("X74:X81").Value2
' We no longer need the data table range, but we do need the subject table/ column
Dim arrSubjs() As Variant
Let arrSubjs() = Me.Range("F74:F81").Value2
Dim Cnt
' For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
' Dim Clm As Long ' "column" in table array
' For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
' If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then
' Let arrDec(Cnt) = True: Exit For ' we no longer have a decresing sequence
' Else
' End If
' Next Clm
' Next Cnt
End If
' at this point I have in my arrDec() 1 for a decreasing sequence and "" for a non decreasing sequence
Rem loop to build the output string
Dim StrRemmark As String
For Cnt = 1 To UBound(arrDec(), 1)
If arrDec(Cnt, 1) = 1 Then ' False Then
'Let StrRemmark = StrRemmark & " and " & arrSubjs(Cnt, 1)
Let StrRemmark = StrRemmark & ", " & Left(arrSubjs(Cnt, 1), 1) & Mid(LCase(arrSubjs(Cnt, 1)), 2) '
Else
End If
Next Cnt
' add remark
If StrRemmark <> "" Then
'Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let StrRemmark = Mid(StrRemmark, 3) ' this takes off the first ", "
Dim Pos As Long: Let Pos = InStrRev(StrRemmark, ", ", -1, vbBinaryCompare)
If Pos <> 0 Then ' Pos will be 0 if no ", " was found
Let StrRemmark = Application.WorksheetFunction.Replace(StrRemmark, Pos, 2, " and ") ' _3 WorksheetFunction.Replace Method https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Else
' we had no ", " in the final string , so we just have one subject
End If
Let Application.EnableEvents = False
'Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark
Let Me.Range("H40").Value = "Decline in " & StrRemmark & "."
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub
'Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
' Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
'End Function
post for later use,
posting to get URL limk now