Test [Archive] - Excel, Access, PowerPoint and Word VBA Macro Automation Help

View Full Version : Test

Molly Brennholz

02-12-2020, 08:24 PM

These posts are to assist me in answering other Threads

I hope it is OK for me to do this. Please do not delete"

Thanks
Molly

Testing.

Black
BlackAlmost black blue - Darkest Blue in PalletBlack
BlackDark BlueBlack
BlackSecond Darkest Blue in PalletBlack
BlackNavyBlack
BlackBlueBlack
BlackForum BlueBlack

Black
BlackAlmost black blue - Darkest Blue in PalletBlack
BlackDark BlueBlack
BlackSecond Darkest Blue in PalletBlack
BlackNavyBlack
BlackBlueBlack
BlackForum BlueBlack

Almost black blue - Darkest Blue in PalletNavyAlmost black blue - Darkest Blue in PalletNavyAlmost black blue - Darkest Blue in PalletNavyAlmost black blue - Darkest Blue in Pallet

from ......... http://www.excelfox.com/forum/showthread.php/2079-test-BB-Code?p=9821#post9821
http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table/page5
https://www.excelforum.com/tips-and-tutorials/1089404-posting-an-html-table-in-a-forum-thread.html#post4642554
http://www.excelforum.com/the-water-cooler/1068075-just-testing-img-cannot-do-it-in-test-forum-as-img-is-off-there-no-reply-needed-2.html#post4109080
http://www.excelfox.com/forum/showthread.php/2079-test-BB-Code?p=9821#post9821

_____ Workbook: LibroSoci.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1

2

3Ciao

4
Worksheet: LibroSoci

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=317218#p317218 (https://eileenslounge.com/viewtopic.php?p=317218#p317218)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316940#p316940 (https://eileenslounge.com/viewtopic.php?p=316940#p316940)
https://eileenslounge.com/viewtopic.php?p=316927#p316927 (https://eileenslounge.com/viewtopic.php?p=316927#p316927)
https://eileenslounge.com/viewtopic.php?p=317014#p317014 (https://eileenslounge.com/viewtopic.php?p=317014#p317014)
https://eileenslounge.com/viewtopic.php?p=317006#p317006 (https://eileenslounge.com/viewtopic.php?p=317006#p317006)
https://eileenslounge.com/viewtopic.php?p=316935#p316935 (https://eileenslounge.com/viewtopic.php?p=316935#p316935)
https://eileenslounge.com/viewtopic.php?p=316875#p316875 (https://eileenslounge.com/viewtopic.php?p=316875#p316875)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

Molly Brennholz

02-12-2020, 08:50 PM

This post is to help me answering here:

http://www.excelfox.com/forum/showthread.php/2418-Work-on-excel-file-from-access-vba?p=12177#post12177

Download both uploaded files
( Save them in the same place )
Open file
“OpenAndRunMemacros.xls”

Run macro Sub MeMacroClitbored()

That should cause the file LibroSoci.xls to be opened. It looks like this
_____ Workbook: LibroSoci.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1

2

3Ciao

4
Worksheet: LibroSoci

That should do _ some things with the variable NTes

_ The variables contents appear in a message box
LibroSociMsgBox.JPG : https://imgur.com/pEnKG7u
2731

¬
_ The code lines,
rowNo = xlBook.Worksheets("LibroSoci").Range("C:C").Find(What:=NTes, LookIn:=xlValues).Row
xlBook.Worksheets("LibroSoci").Cells(rowNo, 4) = Year(Date) ,
are used.
So LibroSoci.xls changes to this:
UseCodeLine.JPG : https://imgur.com/11g5OHX
2732

_____ Workbook: LibroSoci.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1

2

3Ciao
2020

4
Worksheet: LibroSoci

Coding in
"LibroSoci.xls"

ThisWorkbookCodeModuleLibroSoci.jpg: https://imgur.com/WYo3jrJ
2735

Option Explicit
Private Sub Workbook_Open()
'Stop
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim NTes As String
objDataObject.GetFromClipboard: Let NTes = objDataObject.GetText()
MsgBox prompt:=NTes
Dim xlBook As Workbook
'Dim xlSheet As Excel.Worksheet
'Dim xldata As Excel.Range
'Dim ExcelPath As String
Dim rowNo As Long
' ExcelPath = ThisWorkbook.Path & "\" ' CurrentProject.Path & "\"
' Set xlapp = CreateObject("Excel.Application")
' Set xlBook = xlapp.Workbooks.Open(ExcelPath & "LibroSoci.xls")
Set xlBook = ThisWorkbook
' Set xlSheet = xlBook.Worksheets("LibroSoci")
' xlSheet.Select
' xlSheet.Activate
' With ActiveSheet
Let rowNo = xlBook.Worksheets("LibroSoci").Range("C:C").Find(What:=NTes, LookIn:=xlValues).Row
Let xlBook.Worksheets("LibroSoci").Cells(rowNo, 4).Value = Year(Date)
' If Me.Nuova_TessElett <> "" Then
' xlBook.Worksheets("LibroSoci").Cells(rowNo, 37) = Me.Nuova_TessElett
' End If
' End With
End Sub

Coding in
"OpenAndRunMeMacros.xls"

Option Explicit
Sub MeMacroClitbored()
Dim NTes As String: Let NTes = "Ciao"
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText NTes
objDataObject.PutInClipboard
Application.OnTime EarliestTime:=Now(), Procedure:="AggiornaLibroSoci"
End Sub
Sub AggiornaLibroSoci()
Dim xlapp As Excel.Application
Dim xlBook As Excel.Workbook
'Dim xlSheet As Excel.Worksheet
'Dim xldata As Excel.Range
Dim ExcelPath As String
'Dim rowNo As Long
Let ExcelPath = ThisWorkbook.Path & "\" ' CurrentProject.Path & "\"
Set xlapp = CreateObject("Excel.Application")
Let xlapp.Visible = True
Set xlBook = xlapp.Workbooks.Open(ExcelPath & "LibroSoci.xls")
' Set xlSheet = xlBook.Worksheets("LibroSoci")
' xlSheet.Select
' xlSheet.Activate
' ' With ActiveSheet
' rowNo = xlBook.Worksheets("LibroSoci").Range("C:C").Find(What:=NTes, LookIn:=xlValues).Row
' xlBook.Worksheets("LibroSoci").Cells(rowNo, 4) = Year(Date)
' ' If Me.Nuova_TessElett <> "" Then
' ' xlBook.Worksheets("LibroSoci").Cells(rowNo, 37) = Me.Nuova_TessElett
' ' End If
' ' End With
' xlBook.Save
xlBook.Close
xlapp.Quit
' Set xlSheet = Nothing
Set xlBook = Nothing
Set xlapp = Nothing
End Sub

Molly Brennholz

02-12-2020, 11:39 PM

This post is to help me answering here:

http://www.excelfox.com/forum/showthread.php/2418-Work-on-excel-file-from-access-vba?p=12177#post12177

It is a similar idea as in the last post. The only difference is that the text information is passed via a text file.

So as before, both files should be downloaded to the same place.
File "OpenAndRunMeMacros.xls" should be opened and this time the macro Sub MeMacroTextMies() should be run.
( You do not need to do anything about the text file. That will be made the first time Sub MeMacroTextMies() is run , and subsequently it will be overwritten by each further run of Sub MeMacroTextMies(). )

Sub MeMacroTextMies() running should cause "LibroSociTextMies.xls" to be opened, and as before a similar set of events should take place:
A message box pops up:
LibroSociTextMiesMsgBox.JPG : https://imgur.com/5sAvqPP
2742

and then the file "LibroSociTextMies.xls" is modified:
UseCodeLine2.JPG : https://imgur.com/SKeW4MQ
2743

Coding in "OpenAndRunMeMacros.xls"

Sub MeMacroTextMies()
Dim NTes As String: Let NTes = "Ciao"
Dim strcFileName As String: Let strcFileName = "Timer.txt"
Dim intFile As Long: Let intFile = FreeFile
Open ThisWorkbook.Path & "\" & strcFileName For Output As #intFile
Write #intFile, NTes
Close intFile
Application.OnTime EarliestTime:=Now(), Procedure:="AggiornaLibroSociTexties"
End Sub
Sub AggiornaLibroSociTexties()
Dim xlapp As Excel.Application
Dim xlBook As Excel.Workbook
Dim ExcelPath As String
Let ExcelPath = ThisWorkbook.Path & "\" ' CurrentProject.Path & "\"
Set xlapp = CreateObject("Excel.Application")
Let xlapp.Visible = True
Set xlBook = xlapp.Workbooks.Open(ExcelPath & "LibroSociTextMies.xls")
xlBook.Close
xlapp.Quit

Set xlBook = Nothing
Set xlapp = Nothing
End Sub

Coding in "LibroSociTextMies.xls"

Option Explicit
Private Sub Workbook_Open()
Dim intFile As Long: Let intFile = FreeFile
Dim strcFileName As String: Let strcFileName = "Timer.txt"
Open ThisWorkbook.Path & "\" & strcFileName For Input As #intFile
Dim NTes As String
Input #intFile, NTes
Close intFile
MsgBox prompt:=NTes
Dim xlBook As Workbook
Dim rowNo As Long
Set xlBook = ThisWorkbook
Let rowNo = xlBook.Worksheets("LibroSoci").Range("C:C").Find(What:=NTes, LookIn:=xlValues).Row
Let xlBook.Worksheets("LibroSoci").Cells(rowNo, 4).Value = Year(Date)
End Sub

Molly Brennholz

02-16-2020, 06:45 PM

... Feeling horny..
C ja later
x

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=317218#p317218 (https://eileenslounge.com/viewtopic.php?p=317218#p317218)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316940#p316940 (https://eileenslounge.com/viewtopic.php?p=316940#p316940)
https://eileenslounge.com/viewtopic.php?p=316927#p316927 (https://eileenslounge.com/viewtopic.php?p=316927#p316927)
https://eileenslounge.com/viewtopic.php?p=317014#p317014 (https://eileenslounge.com/viewtopic.php?p=317014#p317014)
https://eileenslounge.com/viewtopic.php?p=317006#p317006 (https://eileenslounge.com/viewtopic.php?p=317006#p317006)
https://eileenslounge.com/viewtopic.php?p=316935#p316935 (https://eileenslounge.com/viewtopic.php?p=316935#p316935)
https://eileenslounge.com/viewtopic.php?p=316875#p316875 (https://eileenslounge.com/viewtopic.php?p=316875#p316875)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

Molly Brennholz

03-20-2020, 11:08 AM

Screenshots I need to help answer the post that is just here:
http://www.excelfox.com/forum/showthread.php/2433-vba-to-put-remark

If column I is sell then see the value of column K & if column K is Greater than sheet2 of column E then put the remark in sheet3 in the stock name from column B
If column I is buy then see the value of column K & if column K is lower than sheet2 of column F then put the remark in sheet3 in the stock name from column B
remark will be in series like 1,2,3,4,5,6 and so on
vba is palced in a separate file
all files are located in same place
and after putting the remark clear sheet 1 and sheet 2

If column I is sell then see the value of column K &
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEACCEQ
10
11
12
13
8SELL
11.247
1100.947

3NSEADANIENTEQ
8
7
6
5
4BUY
1.334
130.734

4
Worksheet: Sheet1

if column K is Greater than sheet2 of column E
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEACCEQ
1
1102
18
4
2

3NSEADANIENTEQ
5
6
129
8
4

4
Worksheet: Sheet2

E then put the remark in sheet3 in the stock name from column B
Row\Col
A
B
C
D
E
F
G

1Symbol

2ACC
1
2
3

3ADANIENT
1

4

5

6

7remark I have puuted 1 bcoz series start with 1

8and next time when I will run the macro

9then it will start with 2

10and again when I will ran the macro then it will start with 3
Worksheet: Sheet3

If column I is buy then see the value of column K & if column K is lower than sheet2 of column F then put the remark in sheet3 in the stock name from column B
remark will be in series like 1,2,3,4,5,6 and so on
vba is palced in a separate file
all files are located in same place
and after putting the remark clear sheet 1 and sheet 2

arrS1()

ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

NSEACCEQ
10
11
12
13
8SELL
11.247
1100.947

NSEADANIENTEQ
8
7
6
5
4BUY
1.334
130.734

arrS2()

ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

NSEACCEQ
1
1102
18
4
2

NSEADANIENTEQ
5
6
129
8
4

arrS3()

Symbol

ACC
1
2
3

ADANIENT
1

Symbol

ACC
1
2
3

ADANIENT
1

Your data ????? :confused:
SELL is K=1100.947 , sheet 2 column E is 1102 … so K is NOT > column E ---- so no output – no remark
BUY is K = 130.734 , sheet 2 column E is 129 … so K is NOT < column E ----- so no output – no remark

_.....see next post............._

Molly Brennholz

03-20-2020, 12:58 PM

_...........from last post

Try this data:

_____ Workbook: Merge2.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEACCEQ
10
11
12
13
8SELL
11.247
1234

3NSEADANIENTEQ
8
7
6
5
4BUY
1.334
125

4
Worksheet: Sheet1

Option Explicit
Sub HidnInLisWb() '
Rem 1 Worksheets info
Dim Wbm As Workbook, Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Set Wbm = Workbooks("Merge2.xls")
Set Ws1 = Wbm.Worksheets("Sheet1"): Set Ws2 = Wbm.Worksheets("Sheet2"): Set Ws3 = Wbm.Worksheets("Sheet3")
Rem 2 data Input
Dim arrS1() As Variant, arrS2() As Variant, arrS3() As Variant
Let arrS1() = Ws1.Range("A1").CurrentRegion.Value: arrS2() = Ws2.Range("A1").CurrentRegion.Value
'2b
ReDim arrS3(1 To UBound(arrS1(), 1)) ' A 1 dimension array of arrays
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output

Rem 3
Dim cnt
For cnt = 2 To UBound(arrS1(), 1) ' "row" count, cnt
'2b)(ii)
Dim Lc As Long: Let Lc = Ws3.Cells.Item(cnt, Ws3.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
Let arrS3(cnt) = Ws3.Range("A" & cnt & ":" & CL(Lc + 1) & cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays
Select Case arrS1(cnt, 9) ' column I
Case "SELL" 'If column I is sell
If arrS1(cnt, 11) > arrS2(cnt, 5) Then ' if column K is Greater than sheet2 of column E then
Let arrS3(cnt)(1, UBound(arrS3(cnt), 2)) = UBound(arrS3(cnt), 2) - 1 ' Put in a value in last array "column"
Else
End If
Case "BUY" 'If column I is buy
If arrS1(cnt, 11) < arrS2(cnt, 6) Then ' if column K is lower than sheet2 of column F then
Let arrS3(cnt)(1, UBound(arrS3(cnt), 2)) = UBound(arrS3(cnt), 2) - 1 ' Put in a value in last array "column"
Else
End If
End Select
'3b) output "row"
Let Ws3.Range("A" & cnt & "").Resize(1, Lc + 1).Value = arrS3(cnt)
Next cnt
Rem 4 ....and after putting the remark clear sheet 1 and sheet 2
Ws1.cells.Clear
Ws2.cells.Clear
End Sub

'If column I is sell
'then see the value of column K &
'if column K is Greater than sheet2 of column E then put the remark in sheet3 in the stock name from column B

'If column I is buy
'see the value of column K &
'if column K is lower than sheet2 of column F then put the remark in sheet3 in the stock name from column B
'remark will be in series like 1,2,3,4,5,6 and so on
'vba is palced in a separate file
'all files are located in same place
'and after putting the remark clear sheet 1 and sheet 2

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
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

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=317218#p317218 (https://eileenslounge.com/viewtopic.php?p=317218#p317218)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316955#p316955 (https://eileenslounge.com/viewtopic.php?p=316955#p316955)
https://eileenslounge.com/viewtopic.php?p=316940#p316940 (https://eileenslounge.com/viewtopic.php?p=316940#p316940)
https://eileenslounge.com/viewtopic.php?p=316927#p316927 (https://eileenslounge.com/viewtopic.php?p=316927#p316927)
https://eileenslounge.com/viewtopic.php?p=317014#p317014 (https://eileenslounge.com/viewtopic.php?p=317014#p317014)
https://eileenslounge.com/viewtopic.php?p=317006#p317006 (https://eileenslounge.com/viewtopic.php?p=317006#p317006)
https://eileenslounge.com/viewtopic.php?p=316935#p316935 (https://eileenslounge.com/viewtopic.php?p=316935#p316935)
https://eileenslounge.com/viewtopic.php?p=316875#p316875 (https://eileenslounge.com/viewtopic.php?p=316875#p316875)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

Molly Brennholz

03-20-2020, 03:48 PM

From last post

_____ Workbook: Merge2.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R

1Symbol=arrS3(1)arrS3(1)(1, UBound(arrS3(1), 2)) = Symbol

2ACC
1
2
3=arrS3(2)arrS3(2)(1, UBound(arrS3(2), 2)) =
3

3ADANIENT
1=arrS3(2)arrS3(3)(1, UBound(arrS3(3), 2)) =
1

4

5

6

7remark I have puuted 1 bcoz series start with 1

8and next time when I will run the macro

9then it will start with 2

10and again when I will ran the macro then it will start with 3

11

12arrS3()={ arrS3(1) ,arrS3(2) ,arrS3(3) }

13

14

15

16

17

18

19

20arrS3(cnt)(1, UBound(arrS3(cnt), 2)) =

21

22
Worksheet: Sheet3 (2)

_____ Workbook: Merge2.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R

1Symbol=arrS3(1)arrS3(1)(1, UBound(arrS3(1), 2)) = Symbol

2ACC
1
2
3=arrS3(2)arrS3(2)(1, UBound(arrS3(2), 2)) =
3

3ADANIENT
1=arrS3(2)arrS3(3)(1, UBound(arrS3(3), 2)) =
1

4

5

6

7remark I have puuted 1 bcoz series start with 1

8and next time when I will run the macro

9then it will start with 2

10and again when I will ran the macro then it will start with 3

11

12arrS3()={ arrS3(1) ,arrS3(2) ,arrS3(3) }

13

14

15

16

17

18

19

20arrS3(cnt)(1, UBound(arrS3(cnt), 2)) =

21

22
Worksheet: Sheet3 (2)

Molly Brennholz

04-29-2020, 02:32 PM

Some notes to help me in solving this Thread:
http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

_____ Workbook: 1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
25
6>
50000AGTT

2NSE
22
6>
10000AGTT

3NSE
15083
6>
70000AGTT

4NSE
17388
6>
20000AGTT

5NSE
100
6>
170000AGTT

6
Worksheet: Sheet1 (4)

If column B of 2.xlsm match with column B of 1.xls then paste the data from column C of 2.xls as 1,2,3,4,5 and so on....
&
If column B of 2.xlsm doesn't match with column B of 1.xls then delete all the data from column C of that row

_____ Workbook: 2.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1Symbol

2ACC
22
1
2

3ADANIENT
25
1

4ADANIPORTS
15083
1
2
3

5ADANIPOWER
17388
1
2
3
4
5

6AMARAJABAT
100
1
2
3
4

7ASIANPAINT
236
1
2

8

9

10

11

12cells highlighted in red colour doesn’t match with 1.xls show the data from column C will be cleared so 1,2 will be erased

13cells highlighted in green colour matches with 1.xls show we will paste the data from column C
but if column C has data then we will paste to column D
and if column D also has data then column E and so on….

14highlighted colour is only for understanding purpose in actual file there will not be any highlighted colour data

15
Worksheet: Sheet1

Molly Brennholz

04-29-2020, 03:11 PM

Continued from previous post
Some notes to help me in solving this Thread:
http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

I will answer this similar to the last question for consistency to help in understanding, and also do it in a way that might not be the most efficient, but may help in further modifications or similar requirements that I would not be surprised might follow…

Regardless of, and before any checks for meeting the match criteria are done I will make an array of arrays as previously, arr3()
This will be a one dimensional array. For the test data from the previous post this will have a size of 6 main elements, ( 7 incl. Header - arr3(0) not used ) , each of which is a single row, 2 dimensional array of the original data in 2.xlsm with the addition of an extra last element.

ACC
22
1
2
3

ADANIENT
25
1
2

ADANIPORTS
15083
1
2
3
4

ADANIPOWER
17388
1
2
3
4
5
6

AMARAJABAT
100
1
2
3
4
5

ASIANPAINT
236
1
2
3

[ _____ Workbook: 2.xlsm ( Using Excel 2007 32 bit )

arr3() = { arr3(1) ,arr3(2) ,arr3(3) ,arr3(4) ,arr3(5) ,arr(6) }

arr3(1) = ACC
22
1
2
3

arr3(2) =ADANIENT
25
1
2

arr3(3) =ADANIPORTS
15083
1
2
3
4

arr3(4) =ADANIPOWER
17388
1
2
3
4
5
6

arr3(5) =AMARAJABAT
100
1
2
3
4
5

arr3(6) =ASIANPAINT
236
1
2
3

Molly Brennholz

04-29-2020, 04:25 PM

Macro for
http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

Sub CopyPasterConditionalToPutRemark_1_2_3_etc() '
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Set Wb1 = Workbooks("1.xlsx")
Set Wb2 = ThisWorkbook ' macro will be placed in 2.xlsm
Set Ws1 = Wb1.Worksheets.Item(1): Set Ws2 = Wb2.Worksheets.Item(1)
Rem 2 data Input
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Let arr1() = Ws1.Range("A1:K" & Ws1.Range("A1").CurrentRegion.Rows.Count & "").Value
Let arr2() = Ws2.Range("A1").CurrentRegion.Value ' Current region will not work for arrS1() because columns G to J are empty
'2b
ReDim arr3(0 To UBound(arr2(), 1)) ' A 1 dimension array of arrays , ( the first element arr3(0) we will not use )
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output
Rem 3
Dim Cnt
For Cnt = 2 To UBound(arr2(), 1) ' "row" count, Cnt from after heading untill last row in 2.xlsm ( Ws2 )
'2b)(ii) make and fill the row element array inside the current arr3(cnt) element
Dim Lc As Long: Let Lc = Ws2.Cells.Item(Cnt, Ws2.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
Let arr3(Cnt - 1) = Ws2.Range("A" & Cnt & ":" & CL(Lc + 1) & Cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays. It has one more element than filled columns - this empty last element is filled in the next line
Let arr3(Cnt - 1)(1, UBound(arr3(Cnt - 1), 2)) = UBound(arr3(Cnt - 1), 2) - 2 ' this puts the next integer in the last, currently empty element
'3a) Check for match criteria
Dim mtchRes As Variant
Let mtchRes = Application.Match(arr2(Cnt, 2), Ws1.Range("B1:B" & UBound(arr1(), 1) & ""), 0)
If IsError(mtchRes) Then ' If the last line errored than we did not find a match, so from the 3rd up to the last element need to be rtemoved from the array for this row
Dim Empt As Long
For Empt = 3 To UBound(arr3(Cnt - 1), 2)
Let arr3(Cnt - 1)(1, Empt) = ""
Next Empt
Else
' a match was found, so we do not need to remove the 1 2 3 etc...
End If
'3c) Paste out row
Let Ws2.Range("A" & Cnt & "").Resize(1, Lc + 1).Value = arr3(Cnt - 1)
Next Cnt
Rem 4 ....and after putting the remark clear sheet 1 and sheet 2
' Ws1.Cells.Clear
' Ws2.Cells.Clear
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
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

Share ‘1.xlsx’ : https://app.box.com/s/0yc8icxb03i4vs1h11n20l43frmd52qa
Share ‘2.xlsm’ : https://app.box.com/s/ry312xpb04kwef4wufvvx54qpv1mwai0

Molly Brennholz

04-29-2020, 05:07 PM

Just testing - ignore this post

TESTING CODE PASTE ERROR

' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

Sub CopyPasterConditionalToPutgreen]Remark_1_2_3_etc() '[/color]
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Set Wb1 = Workbooks("1.xlsx")
Set Wb2 = ThisWorkbook ' macro will be placed in 2.xlsm
Set Ws1 = Wb1.Worksheets.Item(1): Set Ws2 = Wb2.Worksheets.Item(1)
Rem 2 data Input
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Let arr1() = Ws1.Range("A1:K" & Ws1.Range("A1").CurrentRegion.Rows.Count & "").Value
Let arr2() = Ws2.Range("A1").CurrentRegion.Value ' Current region will not work for arrS1() because columns G to J are empty
'2b
ReDim arr3(0 To UBound(arr2(), 1)) ' A 1 dimension array of arrays , ( the first element arr3(0) we will not use )
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output
Rem 3
Dim Cnt
For Cnt = 2 To UBound(arr2(), 1) ' "row" count, Cnt from after heading untill last row in 2.xlsm ( Ws2 )
'2b)(ii) make and fill the row element array inside the current arr3(cnt) element
Dim Lc As Long: Let Lc = Ws2.Cells.Item(Cnt, Ws2.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
Let arr3(Cnt - 1) = Ws2.Range("A" & Cnt & ":" & CL(Lc + 1) & Cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays. It has one more element than filled columns - this empty last element is filled in the next line
Let arr3(Cnt - 1)(1, UBound(arr3(Cnt - 1), 2)) = UBound(arr3(Cnt - 1), 2) - 2 ' this puts the next integer in the last, currently empty element
'3a) Check for match criteria
Dim mtchRes As Variant
Let mtchRes = Application.Match(arr2(Cnt, 2), Ws1.Range("B1:B" & UBound(arr1(), 1) & ""), 0)
If IsError(mtchRes) Then ' If the last line errored than we did not find a match, so from the 3rd up to the last element need to be rtemoved from the array for this row
Dim Empt As Long
For Empt = 3 To UBound(arr3(Cnt - 1), 2)
Let arr3(Cnt - 1)(1, Empt) = ""
Next Empt
Else
' a match was found, so we do not need to remove the 1 2 3 etc...
End If
'3c) Paste out row
Let Ws2.Range("A" & Cnt & "").Resize(1, Lc + 1).Value = arr3(Cnt - 1)
Next Cnt
Rem 4 ....and after putting the remark clear sheet 1 and sheet 2
' Ws1.Cells.Clear
' Ws2.Cells.Clear
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
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

Molly Brennholz

05-01-2020, 06:09 PM

Full macro for this post,

Sub CopyPasterConditionalToPutRemark_1_2_3_etcArseOver Tit()

' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional?p=13175&viewfull=1#post13175
Sub CopyPasterConditionalToPutRemark_1_2_3_etcArseOver Tit() '
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Set Wb1 = Workbooks("1 1Mai.xlsx")
Set Wb2 = ThisWorkbook ' macro will be placed in 2.xlsm
Set Ws1 = Wb1.Worksheets.Item(1): Set Ws2 = Wb2.Worksheets.Item(1)
Rem 2 data Input
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Let arr1() = Ws1.Range("A1:K" & Ws1.Range("A1").CurrentRegion.Rows.Count & "").Value
Let arr2() = Ws2.Range("A1").CurrentRegion.Value ' Current region will not work for arrS1() because columns G to J are empty
'2b
ReDim arr3(0 To UBound(arr2(), 1)) ' A 1 dimension array of arrays , ( the first element arr3(0) we will not use )
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output
Rem 3
Dim Cnt
For Cnt = 2 To UBound(arr2(), 1) ' "row" count, Cnt from after heading untill last row in 2.xlsm ( Ws2 )
'2b)(ii) make and fill the row element array inside the current arr3(cnt) element
Dim Lc As Long: Let Lc = Ws2.Cells.Item(Cnt, Ws2.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
Let arr3(Cnt - 1) = Ws2.Range("A" & Cnt & ":" & CL(Lc + 1) & Cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays. It has one more element than filled columns - this empty last element is filled in the next line
Let arr3(Cnt - 1)(1, UBound(arr3(Cnt - 1), 2)) = UBound(arr3(Cnt - 1), 2) - 2 ' this puts the next integer in the last, currently empty element
'3a) Check for match criteria
Dim mtchRes As Variant
Let mtchRes = Application.Match(arr2(Cnt, 2), Ws1.Range("B1:B" & UBound(arr1(), 1) & ""), 0)
If IsError(mtchRes) Then ' If the last line errored than we did not find a match, so we do not need to do anything to the array
' a match was not found, so we do not need to remove the 1 2 3 etc...
Else
' a match was found, so we need to remove the 1 2 3 etc...
Dim Empt As Long
For Empt = 3 To UBound(arr3(Cnt - 1), 2)
Let arr3(Cnt - 1)(1, Empt) = ""
Next Empt
End If
'3c) Paste out row
Let Ws2.Range("A" & Cnt & "").Resize(1, Lc + 1).Value = arr3(Cnt - 1)
Next Cnt
Rem 4 ....and after putting the remark clear sheet 1 and sheet 2
' Ws1.Cells.Clear
' Ws2.Cells.Clear
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
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

Molly Brennholz

05-22-2020, 12:51 AM

Test

askfasfjf

can I post in firefox
Yes... looks like Google Chrome is quirky ( IE as well, but that always was ) ... https screws it up again I expect

x

Molly Brennholz

05-22-2020, 01:38 AM

Notes to assist me in answering this Thread:
https://excelfox.com/forum/showthread.php/2498-Conditionally-Copy-amp-Paste-of-the-data-with-increasing-series-with-Matching

Before
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
Y

1UserIdAccountIdEntityNameExchg-SegSymbolInstrument NameOption TypeNetBuyValueNetSellValueNetValueNetBuyQtyNetSel lQtyNetQtyBEPSellAvgPriceBuyAvgPriceLastTradedPric eMarkToMarketRealized MarkToMarketUnrealized MarkToMarketEL MarkToMarketTrading SymbolClient ContextSeries/ExpiryStrike Price

2WC5758NSEAMBUJACEMEQ
10781.10
10878.30
97.20
54
54
201.45
199.65
201
97.2
-97.2
97.2AMBUJACEM-EQEQ

3WC5758NSEADANIENTEQ
420.60
430.50
9.90
2
2
215.25
210.30
210.35
9.9
9.9
9.9ADANIENT-EQEQ

4WC5758NSEMARICOEQ
1688.40
1713.00
24.60
6
6
285.50
281.40
281.9
24.6
24.6
24.6MARICO-EQEQ

5WC5758NSEAPOLLOTYREEQ
2429.10
2405.70
-23.40
18
18
133.65
134.95
135
-23.4
-23.4
-23.4APOLLOTYRE-EQEQ

6WC5758NSEL&TFHEQ
1765.80
1794.60
28.80
18
18
99.70
98.10
98.25
28.8
28.8
28.8L&TFH-EQEQ
Worksheet: ap-Sheet1

_____ Workbook: Book1.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1Symbol

2AMBUJACEM
22
1
2
3
4
5

3ADANIENT
25
1

4APOLLOTYRE
15083

5ADANIPOWER
17388
1
2
3

6
Worksheet: Sheet1

_____ Workbook: Book1.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J

1Symbol

2AMBUJACEM
22
1
2
3
4
5

3ADANIENT
25
1

4APOLLOTYRE
15083
1
2
3
4
5
6
7

5ADANIPOWER
17388
1
2
3

6
Worksheet: Sheet3

macro will be placed in Book1.xlsm
We have to look on Column S of ap.xls and If column S of ap.xls has negative numbers then we have to look on Column E of ap.xls & we will match that Column E data of ap.xls with column A of sheet1 of Book1.xlsm & if it matches then we will see wheather column C of Book1.xlsm has data in it or not & if column C of Book1.xlsm has data in it then do nothing & if column C of Book1.xlsm doesn't have data then we will go to sheet3 of Book1.xlsm and we will look for a match of Column E data of ap.xls with column A of sheet3 of Book1.xlsm & if it is found then we will copy the data from sheet3 of Book1.xlsm and paste it to sheet1 of book1.xlsm & we increase one more number in series in it

After

_____ Workbook: Book1.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J

1Symbol

2AMBUJACEM
22
1
2
3
4
5

3ADANIENT
25
1

4APOLLOTYRE
15083
1
2
3
4
5
6
7
8

5ADANIPOWER
17388
1
2
3

6

7
Worksheet: Sheet1

macro in next post...

Molly Brennholz

05-22-2020, 03:10 AM

Macro needed , working on the Before of thee last post, which will produce the After of the last post
Macro to solve this Thread : https://excelfox.com/forum/showthread.php/2498-Conditionally-Copy-amp-Paste-of-the-data-with-increasing-series-with-Matching
https://excelfox.com/forum/showthread.php/2498-Conditionally-Copy-amp-Paste-of-the-data-with-increasing-series-with-Matching?p=13414&viewfull=1#post13414

' Conditionally Copy & Paste of the data with increasing series with Matching
Sub Step15() ' https://excelfox.com/forum/showthread.php/2498-Conditionally-Copy-amp-Paste-of-the-data-with-increasing-series-with-Matching
Rem worksheets info
' ap.xls
Dim Wbap As Workbook
Set Wbap = Workbooks("ap.xls")
Dim Wsap As Worksheet
Set Wsap = Wbap.Worksheets.Item(1)
Dim Lrap As Long: Let Lrap = Wsap.Range("E" & Wsap.Rows.Count & "").End(xlUp).Row
Dim Arrap As Variant: Let Arrap = Wsap.Range("A1:Y" & Lrap & "").Value2
' Book1.xlsm
Dim Wb1 As Workbook
Set Wb1 = ThisWorkbook
Dim Ws1 As Worksheet, Ws3 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1): Set Ws3 = Wb1.Worksheets.Item(3)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' column A of sheet1 of Book1.xlsm
Dim arrC() As Variant: Let arrC() = Ws1.Range("C1:C" & Lr1 & "").Value2 ' column C of sheet1 of Book1.xlsm
Dim Lr3 As Long: Let Lr3 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA3() As Variant: Let arrA3() = Ws3.Range("A1:A" & Lr1 & "").Value2 ' column A of sheet3 of Book1.xlsm
Rem We have to look on Column S of ap.xls and If column S of ap.xls has negative numbers then
Dim Cnt As Long
For Cnt = 2 To Lrap ' going down rows in ap worksheet 1
If Arrap(Cnt, 19) < 0 Then ' If column S of ap.xls has negative numbers then
Dim Eap As String: Let Eap = Arrap(Cnt, 5) ' then we have to look on Column E of ap.xls - Column E data
Dim mtchRes As Variant ' & we will match that Column E data of ap.xls with column A of sheet1 of Book1.xlsm
Let mtchRes = Application.Match(Eap, arrA(), 0)
If IsError(mtchRes) Then
' no match
Else ' see whether column C of Book1.xlsm has data in it or not
If arrC(mtchRes, 1) = "" Then
Dim mtchRes3 As Variant ' go to sheet3 of Book1.xlsm and we will look for a match of Column E data of ap.xls with column A of sheet3 of Book1.xlsm
Let mtchRes3 = Application.Match(Eap, arrA3(), 0)
If IsError(mtchRes3) Then
' no match
Else
Dim Lc As Long: Let Lc = Ws3.Cells.Item(mtchRes3, Ws3.Cells.Columns.Count).End(xlToLeft).Column
Dim arr3() As Variant
Let arr3() = Ws3.Range("A" & mtchRes & ":" & CL(Lc + 1) & mtchRes & "").Value ' An array for all data of that row in sheet3 and an extra column
Let arr3(1, UBound(arr3, 2)) = UBound(arr3(), 2) - 2 ' this puts the next integer in the last, currently empty element ............ increase one more number in series in it
' we will copy the data from sheet3 of Book1.xlsm and paste it to sheet1 of book1.xlsm & we ................................... increase one more number in series in it
' Paste out row
Let Ws1.Range("A" & mtchRes & "").Resize(1, Lc + 1).Value = arr3()
End If
Else ' column c has data in it
' do nothing
End If

End If

Else ' not a negative in S column

End If

Next Cnt
End Sub
'
' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
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 is also in Book1.xlsm
Share ‘Book1.xlsm’ : https://app.box.com/s/qotw65wmiq1aln7frg9o5gys8ke1l8xh
Share ‘ap.xls’ : https://app.box.com/s/r0tc0hkwoxrqjsqfu4gh7eqyy5jmqlg2

Molly Brennholz

06-27-2020, 01:46 PM

Just testing colours in code....

standard:

' The solution from karmapala at excelforum 20 June 2020
' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174
Sub karmapala()
'Dim arr() As Variant
Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet
Set Wb1 = Workbooks("1.xls")
Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1")
Dim Rng As Range ' For main data range in 1.xls
' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( .
' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))'
Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp))
Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm")
Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1")
Dim X As Long
X = 0
Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
Dim Cel As Range
For Each Cel In Rng
Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then
' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ...
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If

'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then
If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' ....
ReDim Preserve arr(X)
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
End If
Next

If X = 0 Then Exit Sub

Rem 3 In this section we
Dim El
For Each El In arr() ' arr
Dim C
Set C = Sh2.Range("B:B").Find(El, lookat:=xlWhole)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
If C.Offset(0, 1).Value = "" Then
C.Offset(0, 1).Value = 1
Else
C.End(xlToRight).Offset(0, 1).Value = C.End(xlToRight).Value + 1
End If
Set C = Sh2.Range("B:B").FindNext(C)
Loop While C.Address <> FirstAddress
End If
Next

End Sub

Molly Brennholz

06-27-2020, 01:47 PM

testing following on from last post...

What can young Kyle offer me.....

' The solution from karmapala at excelforum 20 June 2020
' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174
Sub karmapala()
'Dim arr() As Variant
Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet
Set Wb1 = Workbooks("1.xls")
Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1")
Dim Rng As Range ' For main data range in 1.xls
' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( .
' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))'
Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp))
Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm")
Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1")
Dim X As Long
X = 0
Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
Dim Cel As Range
For Each Cel In Rng
Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then
' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ...
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If

'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then
If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' ....
ReDim Preserve arr(X)
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
End If
Next

If X = 0 Then Exit Sub

Rem 3 In this section we
Dim El
For Each El In arr() ' arr
Dim C
Set C = Sh2.Range("B:B").Find(El, lookat:=xlWhole)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
If C.Offset(0, 1).Value = "" Then
C.Offset(0, 1).Value = 1
Else
C.End(xlToRight).Offset(0, 1).Value = C.End(xlToRight).Value + 1
End If
Set C = Sh2.Range("B:B").FindNext(C)
Loop While C.Address <> FirstAddress
End If
Next

End Sub

Molly Brennholz

10-03-2020, 02:06 PM

Test Images

Upload icon wont worK ???? error*******

try Imgur.com

1_ link
https://imgur.com/UfmFTQy

2_ HTML embed

<blockquote class="imgur-embed-pub" lang="en" data-id="UfmFTQy"><a href="https://imgur.com/UfmFTQy">View post on imgur.com</a></blockquote><script async src="//s.imgur.com/min/embed.js" charset="utf-8"></script>
<blockquote class="imgur-embed-pub" lang="en" data-id="UfmFTQy"><a href="https://imgur.com/UfmFTQy">View post on imgur.com</a></blockquote><script async src="//s.imgur.com/min/embed.js" charset="utf-8"></script>

3_ BBCode(Forums)
https://i.imgur.com/UfmFTQy.jpg
https://i.imgur.com/UfmFTQy.jpg

4_ Markdown (Reddit)
(https://imgur.com/UfmFTQy)

BTW **** this was the error on upload attempt:

[IOErrorEvent type="ioError" bubbles=false cancellable=false eventPhase=2 text="Error
#2038"]

Here is a screenshot, to get that error message you hover with the mouse over the red bit:
[img]https://i.imgur.com/ISFb2g0.jpg

Molly Brennholz

10-03-2020, 02:47 PM

test

https://i.imgur.com/UfmFTQy.jpg
https://i.imgur.com/UfmFTQy.jpg

test

' Index(OneDimensionalArray(), 1 , 1
' 1 2
' 1 3
' 1 4
' 1 5 )

' Index(OneDimensionalArray(), 1 , 1
' 1 2
' 1 3
' 1 4
' 1 5 )

' Head1 , Haed2 , Head3
' 2 , 7 , 4
' 3 , 9 , 5

' Index( Head1 , 2, 3 1 , 1 , 1 1 , 2 , 3
' Head3 , 4, 5 3 , 3 , 3 1 , 2 , 3
' Haed2 , 7, 9 2 , 2 , 2 1 , 2 , 3 )

Molly Brennholz

10-19-2020, 03:00 PM

In support of this post:
https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028

I am not totally sure what the OP is asking.
Is the OP asking
(i) _ to put values into an existing array where that existing array already has values in it
or
(ii)_ changing the array dimension and positioning of elements in an array
or
(iii)_ maybe its lost in the translation and/ or the OP is not sure him/herself.
The initial answer to (i)_ I think we seem clear about:- It will likely in VBA require a code line for each element to be "moved" from one array to the other , so likely looping will be involved for a multi element array.
The Thread title and OPs first question infers to me converting a 1 D array to a 2 D array, without looping.
If the existing array with values already in it is a dynamic array, then overwriting along with re dimensioning means that those (i)_ and (ii)_ are somewhat merged in meaning anyway.
So I am not totally clear what is going on here, but I think it there is a discussion of generally … …"1 D arrays to 2 D arrays"
So lets say we are talking generally about …"1 D arrays to 2 D arrays" and leave it loosely defined for now and go with that…

Frederick has shown in his second code line that a characteristic of the Transpose function is that if a 1 D array is given to the Transpose function then the transposed array becomes a 2 D array , all be it a quasi "1 column array" ***
Transpose does that, as it does the opposite way converting a single column 2D array to a 1D array.
I think most of us are not quite sure why it has been wired to do that. Some other things seem to default to making a "one row" thing be a 1D array rather than a 2D array, even when the thing it may have been given to work on was a 2D array. ( It does not screw things up to badly when playing with spreadsheets since that transposed in its final 1 D form will be "seen" by Excel as if it was a single row 2 Dimensional array when applied to a spreadsheet range. So usually a "row" becomes a row, if you catch my drift).
We can go the other way. ( If we do that with Rick's example , we will see a small difference, the 1 D array returned will have indices of 1 2 3 4 5 as opposed to the 0 1 2 3 4 , (since the Split function Rick used returns those starting a base 0 ) . I am not sure why Excel chooses to start a t 1 in this case: Possibly it was just made that way because its more often to do with worksheet/spreadsheet stuff, and we think about rows and columns starting at 1, and something like a row of 1 is a bit stupid. )

Index with arrays as co ordinate arguments
This stuff is worth knowing about:
A further function that can be very helpful in doing this sort of manipulation of arrays without looping is the Index Function. It becomes so useful because it will accept arrays in place of the more conventional single value indices in its second ( row ) and third ( column ) arguments. The evaluation is then done in the conventional Excel way, "along the columns of a row" , then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row , ….etc. Usually VBA will do its best to give out the results in an array dimensioned appropriate for the array dimensions supplied in those second and third arguments, following the conventional "along the columns of a row" , then down to repeat at the next row: along the columns of that row, ………

As example we can do that Transpose code line in this pseudo way

' Index(OneDimensionalArray(), 1 , 1
' 1 2
' 1 3
' 1 4
' 1 5 )
We are doing 5 calculations there, talking each time the first row and consecutive columns, the result coming out in a form that the Excel calculations are done - .. "along the columns of a row" , then down to repeat at the next row… but we only have one column in this case, so that is actually just going down the rows, 5 times. Hence our output is the 90degree transpose of OneDimensionalArray()

That was just one example, but the important point is that you can supply different arrays in the Index second ( "row" ) and third ( "column" ) arguments. So you can pretty well take any1 or 2 D array in the Index first argument, and in one code line, without looping , put all or some of the values from that array in some other order in any other 1 or 2 D array. That could be what the OP was asking for ….
Dim Array1(2, 2) As Integer
Dim Array2(2) As Integer
…………… way to copy the values from Array2 into Array1?
The restriction is that we can't make use of this to put values into Array1( ) if it already existed. You would have to be in like having
Dim Array1() As Variant
Dim Array2(2) As Integer
-……..
Array1()= Index ( Array2(2) , { _.... } , { _... } )
( Variant is needed in the first declaration as the index chucks its output values housed in Variant types. AFAIK the first argument can be any sort of 1 D or 2 D array, ( or it can be any range object ) )

Another not looping option to assist in a conversion could be to remove rows or columns of a 2 D array with a single code line. Best look at some posts of Rick ( Frederick Rothstein (https://excelfox.com/forum/forumdisplay.php/22-Rick-Rothstein-s-Corner) 's ) , stuff for that ( https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array )

One last curiosity , a weird thing I only recently came across. An array of arrays, sometimes refereed as a "jagged array", is peculiarly treated in some cases by Index as a 2 D array. This gives us some interesting further one liner code line possibilities.
Example, If I had a 1 D array of 1 D arrays, something of this sort of form
{ { "Head1" , 2, 3 } , {"Head3", 4, 5 } , {"Haed2", 7, 9} }
then I can convert that, for example, to re ordered in data columns like this

' Head1 , Haed2 , Head3
' 2 , 7 , 4
' 3 , 9 , 5
I can do that using like a Index one code liner pseudo

' Index( Head1 , 2, 3 1 , 3 , 2 1 , 1 , 1
' Head3 , 4, 5 1 , 3 , 2 2 , 2 , 2
' Haed2 , 7, 9 1 , 3 , 2 3 , 3 , 3 )

I put some more details of all I have been saying , in a macro in the uploaded file. Probably its best to step through the macro in Debug mode ( do that by hitting Key F8 after clicking anywhere in the macro )

Hello Adam.
I expect you are referring specifically to the idea of putting existing values from an array into another existing array, although I am not fully clear if the OP wanted that: Possibly the language barrier prevented the OP getting anything out of the links you gave him…. The best thing probably, as Rory asked for, was an example from the OP of what he wanted to do…
Anyway, you probably know all the following, but I thought I'd add it to the Thread, while I am in the mood…
Generally questions along the lines of "1 D array to 2 D array" or visa versa are quite common in Excel VBA. I expect this is because
_ a) a lot of things done "internally" in coding involve 1 D arrays,
but/ and
_ b) a range from a spreadsheet will often likely end up in an array of 2 Dimensions, I think Excel does this so that we can make the distinction what is a row and what is a column.***
So things might not always work as we wanted, for example a problem might occur when a 1 D array appears when a 2 D array was expected/ wanted, and visa versa. To solve the problem a conversion from a 1D to 2D or visa versa might get us out of trouble.
Example: we got a Join function that is something like the reverse of the Split function mentioned in this Thread (https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5402848). Basically you can use it to join the contents of an array into a string. The bummer is that it only accepts a 1 D array. So if I give it a column or row of data to Join it will error. You'll need to change the 2D array got from a spreadsheet single row or a spreadsheet single column to a 1D array for join to work on it. ( One way you can do that is with some of the one liner codings I been talking about

Molly Brennholz

11-18-2020, 02:12 PM

Test

Test formula post

https://www.excelforum.com/excel-formulas-and-functions/1332474-matrix-multiplication.html

=_xlfn.SINGLE(MMULT(TRANSPOSE(N(IF({1};$B$37:$B$45 )));(($K57>=$C$37:$C$45)*(L$54=$A$37:$A$45))))*$D39

_____ Workbook: Customer Forecast.xlsx ( Using Excel 2007 32 bit )
Row\Col
L

57
=_xlfn.SINGLE(MMULT(TRANSPOSE(N(IF({1},$B$37:$B$45 ))),(($K57>=$C$37:$C$45)*(L$54=$A$37:$A$45))))*$D39
Worksheet: Forum

_____ Workbook: Customer Forecast.xlsx ( Using Excel 2007 32 bit )
Row\Col
L

57
=_xlfn.SINGLE(MMULT(TRANSPOSE(N(IF({1},R37C2:R45C2 ))),((RC11>=R37C3:R45C3)*(R54C=R37C1:R45C1))))*R[-18]C4
Worksheet: Forum

Molly Brennholz

11-19-2020, 12:16 PM

Testing, Image comparisons:
https://www.excelforum.com/development-testing-forum/1332696-testit.html
https://excelfox.com/forum/showthread.php/2419-Test-my-appendages?p=15125&viewfull=1#post15125

38KB 640x240 pixels( 37.6 KB )
https://imgur.com/2iPqifH https://i.imgur.com/2iPqifH.jpg
https://i.imgur.com/2iPqifH.jpg
[SecurityErrorEvent type=”securityError” bubbles=false cancellable=false eventPhase=2
Text= “Error #2049]
3462
3462
704842
704842

50% at https://resizeimage.net/ is 310x120 pixels( 28 KB )
https://imgur.com/WwnXByf https://i.imgur.com/WwnXByf.jpg
https://i.imgur.com/WwnXByf.jpg
3462
3462
704843
704843

100% is 608x322 pixels( 43.3 KB )
https://imgur.com/mlooaC7 https://i.imgur.com/mlooaC7.jpg
https://i.imgur.com/mlooaC7.jpg

50% at https://resizeimage.net/ is 304x161 pixels( 34.1 KB )
https://imgur.com/LlXPOfj https://i.imgur.com/LlXPOfj.jpg
https://i.imgur.com/LlXPOfj.jpg

100% is 627x276 pixels( 47.8 KB )
https://imgur.com/WtDUKYU https://i.imgur.com/WtDUKYU.jpg
https://i.imgur.com/WtDUKYU.jpg

50% at https://resizeimage.net/ is 314x138 pixels( 36 KB )
https://imgur.com/D9KsQuG https://i.imgur.com/D9KsQuG.jpg
https://i.imgur.com/D9KsQuG.jpg

DocAElstein

11-19-2020, 02:52 PM

Testing, Image comparisons:.....
[SecurityErrorEvent type=”securityError” bubbles=false cancellable=false eventPhase=2
Text= “Error #2049] ......]
Molly, you shouldn't get that error for Operating Systems Win7 and higher, ( I can' t remeber if I mentioned that before....

Molly Brennholz

11-19-2020, 03:01 PM

You did, thanks, just adding for posterity and to remind me.. I am still going mostly retro with my OS use

DocAElstein

11-19-2020, 03:03 PM

good for you ;)

Molly Brennholz

11-21-2020, 02:16 PM

Test.... image link

https://i.imgur.com/3KtzElN.jpg
https://i.imgur.com/UdlVPYF.jpg
https://i.imgur.com/A4GSQ4l.jpg
https://i.imgur.com/hoJQsku.jpg
https://i.imgur.com/Yl3ruYV.jpg
https://i.imgur.com/ANt2Qi1.jpg
https://i.imgur.com/D7hJ4mL.jpg

https://i.imgur.com/T4udXZV.jpg

http://i.imgur.com/T4udXZV.jpg

Molly Brennholz

07-12-2023, 12:30 AM

test link images

Further based on your latest explanations, and looking at the uploaded file, it looks like
.a) stuff from the first worksheet SCHOOLS (https://i.postimg.cc/qMzPzHQt/stuff-from-SCHOOLS.jpg) goes to the area Schools in Sample worksheet, / template workbook (https://i.postimg.cc/28btCF8h/area-schools-in-Template-Sample.jpg)
.b) stuff from the second worksheet XXXXX goes to the [url=https://i.postimg.cc/wBVfww08/area-Fund-Related-Services-in-Template-Sample.jpg] area Fund/Related Services in Sample worksheet, / template workbook (https://i.postimg.cc/sDkNxQv8/stuff-from-XXXXX.jpg)

Further based on your latest explanations, and looking at the uploaded file, it looks like
.a) stuff from the first worksheet SCHOOLS (https://i.postimg.cc/qMzPzHQt/stuff-from-SCHOOLS.jpg) goes to the area Schools in Sample worksheet, / template workbook (https://i.postimg.cc/28btCF8h/area-schools-in-Template-Sample.jpg)
.b) stuff from the second worksheet XXXXX (https://i.postimg.cc/sDkNxQv8/stuff-from-XXXXX.jpg) goes to the area Fund/Related Services in Sample worksheet, / template workbook (https://i.postimg.cc/wBVfww08/area-Fund-Related-Services-in-Template-Sample.jpg)

I think I can work on that to give you a start

Before I start: I expect Sheet 1 in your coding is a typo. It probably should be Sheet1. Never mind, I will use .Item(1) instead – that will get the first worksheet no matter what it’s named

This macro will take the version of your main file which I attach to this forum post, and it will produce from that your first workbook, named School 1.xlsx . It uses the Template file version I made and have also attached to this forum post, MyTemplateRaw.xlsx

Most of what I have done you may be able to work through and understand.
In words what it does, at least the new bits I doned for you, which you might not be familiar with:

I do a bit of simple loop while stuff after I find the value you want ( 1 in this example ). It starts when I find the 1, so I know then where the start row is, StRw , then I keep going in the loop while bit until I get the stop row, SpRw

Having got that , I am ready to do the copy paste bit. But I don’t actually use any copy paste method, since that is not very efficient for copying simple values. I use the .Value property thing. To Explain that:
You will see that in a 'comment I have written a pseudo code
' Pseudo code Range1.Value=Range2.Value
Used on the RHS the .Value returns/reads an array of the values in the range all in one go
Used on the LHS the .Value applies/writes the array of values offered on the RHS into the range all in one go.
For that to work properly the ranges will need to be the same size. So in the example in the macro I doned for you, I resized the cell on the LHS to what I know the range size is on the RHS

DocAElstein

07-12-2023, 12:36 PM

Hi Molly,
how's things?

Molly Brennholz

07-12-2023, 03:49 PM

Hi Molly,
how's things?

I am getting fed up with all the young lads, half dead physically, fully brain dead, smart-phone zombies. I need another good ride on your old thumping love Axe

Molly Brennholz

10-08-2023, 05:48 PM

Some notes in support of this main question from the web https://www.excelforum.com/excel-programming-vba-macros/1412835-make-a-created-file-protected-by-password.html , ( for Alan )
Original PM request..
Is it possible for you to help me understand how to make the files created with this code be protected so others cannot make any changes? If it is with a password, that would be optimal, I just don't want any error messages telling the user that a password will allow them to make changes if possible. If that makes sense.
Shortly later Request from here https://www.excelforum.com/excel-programming-vba-macros/1412835-make-a-created-file-protected-by-password.html#post5876012
adjust the following code, to save the files that are being created as protected files (may be opened and viewed but not edited)? If a message is necessary if someone tries to change values, I would want the message to say only 'changes cannot be made without the appropriate password'.

The thing required in the first request I suggested could be a bit difficult. The second looks initially as if it could be straight forward and conventional

Forum Sample.xlsm is the OPs original file from that (https://www.excelforum.com/excel-programming-vba-macros/1412835-make-a-created-file-protected-by-password.html) thread

, and here is a snippit from his coding
dws.Name = dName
dFilePath = dFolderPath & dName & ".xlsx"
Application.DisplayAlerts = False
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True

DocAElstein

10-08-2023, 05:56 PM

Thanks Molly, I'll take a look...Later. x

This is post https://www.excelfox.com/forum/showthread.php/2419-Test?p=23399#post23399
https://www.excelfox.com/forum/showthread.php/2419-Test?p=23399#post23399

Lets take a look at the coding in the OPs file – here it is: https://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-2-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=23400#post23400
But now let’s simplify it a bit to look at the aspect of protection,- in particular at the SaveAs stage, as I am guessing that this could be a good start point. My guess is based on all stuff associated with the Workbook.SaveAs method (Excel) : , ( https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas )
We seem to have an awful lot of possible arguments to use, most likely all optional I expect, since I rarely see most of them ever used.
So let's simplify the OPs coding (https://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-2-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=23400#post23400) just to get to the SaveAs bit
This is all we are interested for the time being

Sub GenerateWorkbooksPerNameSimplified() ' https://www.excelfox.com/forum/showthread.php/2419-Test?p=23399#post23399
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("CROSSACT")
sws.Copy ' This has the effect of producing a new workbook showing in the current instance of Excel,with one worksheet, named CROSSACT But this file does not really exist yet, not until we save
Dim dwb As Workbook
Set dwb = Workbooks(Workbooks.Count) ' The Workbooks collection object has all the workbooks we have open in this instance of Excel. The one with the highest index number ( which will be the same number as the total Count of workbooks ) , will be that one we just effectively added
Set dwb = ActiveWorkbook ' This is an alternative to do the same as the last line, because the workbook we just added will be currentlly active
Dim dFolderPath As String
Let dFolderPath = swb.Path & Application.PathSeparator
Dim dFilePath As String, dName As String
Let dName = "TestSaveAsFile"
Let dFilePath = dFolderPath & dName & ".xlsx"
Dim FleFmat As String
Let FleFmat = "xlOpenXMLWorkbook" ' https://learn.microsoft.com/en-us/office/vba/api/excel.xlfileformat
Let Application.DisplayAlerts = False
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlOpenXMLWorkbook ' https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

dwb.Close
Let Application.DisplayAlerts = True
End Sub

That macro will make a Excel file with name TestSaveAsFile.xlsx which anyone can open and make changes to. https://postimg.cc/bddRDYGf

So Far so good. Now let's look at the password issue. At the current Microsoft documentation for SaveAs ,
https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas ( https://learn.microsoft.com/en-us/office/vba/api/excel.xlfileformat )
, these two optional arguments look like the things to do with passwords.
https://i.postimg.cc/hXbSLBJK/Password-optional-arguments-in-Save-As.jpg (https://postimg.cc/hXbSLBJK)
Most likely Password:= is to prevent opening a file without the correct password
The WriteResPassword:= looks like what we need to look at. So the last coding simply would appear to need an extra WriteResPassword:="123" at the SaveAs line

Sub GenerateWorkbooksPerNameSimplified1() ' https://www.excelfox.com/forum/showthread.php/2419-Test?p=23399#post23399
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("CROSSACT")
sws.Copy ' This has the effect of producing a new workbook showing in the current instance of Excel,with one worksheet, named CROSSACT But this file does not really exist yet, not until we save
Dim dwb As Workbook
Set dwb = Workbooks(Workbooks.Count) ' The Workbooks collection object has all the workbooks we have open in this instance of Excel. The one with the highest index number ( which will be the same number as the total Count of workbooks ) , will be that one we just effectively added
Set dwb = ActiveWorkbook ' This is an alternative to do the same as the last line, because the workbook we just added will be currentlly active
Dim dFolderPath As String
Let dFolderPath = swb.Path & Application.PathSeparator
Dim dFilePath As String, dName As String
Let dName = "TestSaveAsFile"
Let dFilePath = dFolderPath & dName & ".xlsx"
Dim FleFmat As Long
Let FleFmat = 51 ' https://learn.microsoft.com/en-us/office/vba/api/excel.xlfileformat
Let Application.DisplayAlerts = False
dwb.SaveAs Filename:=dFilePath, FileFormat:=FleFmat, WriteResPassword:="123" ' https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

dwb.Close
Let Application.DisplayAlerts = True
End Sub
That initially seems to be doing something close to what may be wanted: On attempting to open , we get this pop up to which we can either give the password or open in read only.
https://i.postimg.cc/mtFbX9nZ/Open-with-password-or-read-only.jpg (https://postimg.cc/mtFbX9nZ)

If you choose to open in read only, you do still seem to be able to make changes, but then if you attempt to save them, you are told you must save under a different name.
Conclusions so far
It would appear that so far, the simple answer is just to add the extra WriteResPassword:="123" at the SaveAs line. ( Of course you can choose any password you like in place of the 123 )

One minor point, about optional arguments:
I prefer the named argunents like this ,
Filename:=dFilePath, FileFormat:=FleFmat, WriteResPassword:="123"
, but we can do it as in the original OP coding just by puting the options in order. By coincidence the OPs original equivalent code line was in the correct order.
dFilePath, xlOpenXMLWorkbook
The order there is

.SaveAs Filename:=dFilePath , FileFormat:=xlOpenXMLWorkbook

The full correct order if using other options is given here https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

.SaveAs Filename:= , FileFormat:= , Password:= , WriteResPassword:= , ReadOnlyRecommended:= , CreateBackup:= , AccessMode:= , ConflictResolution:= , AddToMru:= , TextCodepage:= , TextVisualLayout:= , Local:=

We want just Filename , FileFormat , and WriteResPassword. We don’t want Password
The syntax to allow us to do that is to put an extra comma , which is sometimes referred to as place holder.
Something like this
dwb.SaveAs dFilePath, FleFmat, , "123"
This would be the full coding , just with the SaveAs line changed

Sub GenerateWorkbooksPerNameSimplified2() ' https://www.excelfox.com/forum/showthread.php/2419-Test?p=23399&viewfull=1#post23399
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("CROSSACT")
sws.Copy ' This has the effect of producing a new workbook showing in the current instance of Excel,with one worksheet, named CROSSACT But this file does not really exist yet, not until we save
Dim dwb As Workbook
Set dwb = Workbooks(Workbooks.Count) ' The Workbooks collection object has all the workbooks we have open in this instance of Excel. The one with the highest index number ( which will be the same number as the total Count of workbooks ) , will be that one we just effectively added
Set dwb = ActiveWorkbook ' This is an alternative to do the same as the last line, because the workbook we just added will be currentlly active
Dim dFolderPath As String
Let dFolderPath = swb.Path & Application.PathSeparator
Dim dFilePath As String, dName As String
Let dName = "TestSaveAsFile2"
Let dFilePath = dFolderPath & dName & ".xlsx"
Dim FleFmat As Long
Let FleFmat = 51 ' https://learn.microsoft.com/en-us/office/vba/api/excel.xlfileformat
Let Application.DisplayAlerts = False
dwb.SaveAs dFilePath, FleFmat, , "123" ' https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

dwb.Close
Let Application.DisplayAlerts = True
End Sub