I'm having real trouble creating a string to use as the variable to copy differing tabs each time it's run depending on which cells are ticked.
My code cycles through a row of cells and anything with a tick (P) then adds to the array string.
The text generated in the string is identical to the hard coded equivalent but I get a runtime error 9 when I try to copy the tabs using the string.
The "rw" is populated in a previous macro that call this one.
My code is
public rw, col as long
public add as string
public add1 as variable
sub create_pack
Application.DisplayAlerts = False
Set wb1 = ActiveWorkbook
col1 = 8
add = ""
Do Until col1 > 17
If sh00.Cells(rw, col1) = "P" Then
If add = "" Then
add = """Pack " & col1 - 7 & """"
Else
add = add & ", ""Pack " & col1 - 7 & """"
End If
End If
col1 = col1 + 1
Loop
add1 = Array(add)
wb1.Sheets(add1).Copy
Set wb2 = ActiveWorkbook
Any help gratefully received as I'm completely stumped on this one.
Thank you.
I fixed it by copying tab by tab.
Hope this helps any subsequent viewers.
Sub create_pack()
Application.DisplayAlerts = False
Set wb1 = ActiveWorkbook
col = 8
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.add
wb1.Activate
Do Until col > 17
If sh00.Cells(rw, col) = "P" Then wb1.Sheets("Pack " & col - 7).Copy After:=wb2.Sheets(wb2.Sheets.Count)
col = col + 1
Loop
wb2.Activate
wb2.Sheets("Sheet1").Delete
wb2.Close False
wb1.Activate
End Sub
Related
Scenario: I have a workbook with multiple worksheets. I am trying to use a function (called within a sub) to export arrays with data from certain worksheets. The arrays are created before the function with the content from the worksheet with:
If ws.Name = "AA" Then
expaa = ws.UsedRange.Value
End if
where expaa is previously defined as variant.
The function I am using apparently finishes running, but the output on the new file saved is weird: instead of having one row of headers, the first row is split into 2 for some reason (all the others remain the same).
This is the function I am using:
Function Exporter(arr As Variant, y As String, OutPath As String) As Variant
Dim lrow As Long, lColumn As Long
Dim w2 As Workbook
Dim d As Date
Workbooks.Add
Set w2 = ActiveWorkbook
w2.Worksheets(1).Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
Application.DisplayAlerts = False
w2.SaveAs Filename:=OutPath & "\" & y, FileFormat:=6
Application.DisplayAlerts = True
w2.Close True
End Function
Which I call from the main sub with:
If aa_name <> "" Then
Exporter expaa , "aa_OK", wbpath
End If
where aa_name is the name of the file used to retrieve the path.
Obs: The wbpath variable is a string with the path of my main workbook (therefore the new file is saved at the same location).
Question: What may be causing the first row of my output to be split? How can that be fixed?
Obs2: I know this can be done with copy procedure, and looping through the array and so on. I even got it to work with other methods. This post is only to understand what I am doing wrong with the current code.
Obs3: Regarding the data that is going to be passed: it is a matrix of days, identifiers and data, ex:
Item1 Item2 Item3
01/01/2000 1 1 2
02/01/2000 1 2 1
03/01/2000 2 2 2
with around 2000 rows and 3000 columns.
UPDATE: After retesting the code multiple times, It appears that the data of the first row only gets split when the file is save as csv (when the array is pasted, the output is normal). Any idea on what may be the cause for that?
I know this is old but here is my solution for the googlers. This accepts an array and creates a CSV at a path you define. Its probably not perfect but it has worked so far for me.
Option Explicit
Option Private Module
Public Function SaveTextToFile(ByVal targetarray As Variant, ByVal filepath As String) As Boolean
On Error GoTo CouldNotMakeFile
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fileStream As TextStream
' Here the actual file is created and opened for write access
Set fileStream = fso.CreateTextFile(filepath)
' Write something to the file
Dim Row As Long, Col As Long
For Row = LBound(targetarray, 1) To UBound(targetarray, 1)
For Col = LBound(targetarray, 2) To UBound(targetarray, 2)
fileStream.Write StringCompliance(targetarray(Row, Col)) & IIf(Col = UBound(targetarray, 2), "", ",")
Next Col
fileStream.WriteBlankLines 1
Next Row
' Close it, so it is not locked anymore
fileStream.Close
' Here is another great method of the FileSystemObject that checks if a file exists
If fso.FileExists(filepath) Then
SaveTextToFile = True
End If
CouldNotMakeFile:
End Function
Private Function StringCompliance(ByVal InputString As String) As String
Dim CurrentString As String
CurrentString = InputString
'Test if string has qoutes
If InStr(CurrentString, Chr$(34)) > 0 Then
CurrentString = Chr$(34) & Replace(CurrentString, Chr$(34), Chr$(34) & Chr$(34)) & Chr$(34)
StringCompliance = True
Else
'Tets if string has commas or line breaks
If InStr(CurrentString, ",") > 0 Or InStr(CurrentString, vbLf) > 0 Then
CurrentString = Chr$(34) & CurrentString & Chr$(34)
Else
StringCompliance = False
End If
End If
StringCompliance = CurrentString
End Function
I'm really struggling to find what's generating the 'Subscript Out Of Range' error in my code below. What I'm trying to do with said code is to read data from text files having a time stamp within 90 days of the current date. To collect this data, I'm reading each file line by line, storing that data into a split array, then populating two collections with specific rows of the split array. This code works fine with another application of it that I'm using to retrieve data only from a specific job set. The code in the aforementioned application appears to be working fine until I reach one particular file which doesn't differ in any way (formatting, content, or otherwise) from previous files that were successfully read. It seems to me that I'm reaching the size limit of each collection but I'm not sure. Below is my code:
Private Sub Analyze_90Day_Data_Click()
Application.ScreenUpdating = False
Data_Selection_21075A.Hide
'Declare Variables
Dim FFFile As String
Dim SplitData() As String
Dim DateIter As Long
Dim CurrentDate As Date
Dim FileDate As Date
Dim colSN As String
Dim colSet As String
Dim KPCDate As Date
Dim CMMArray() As Variant
'Remove old data from 21075A KPC
LastRow = Sheets("21075A KPC").Range("G65536").End(xlUp).Row
For SheetRow = 12 To LastRow
Sheets("21075A KPC").Range("G" & SheetRow & ":H" & SheetRow).ClearContents
Next SheetRow
'Populate 21075A KPC with new data
CurrentDate = Date
KPCDate = DateAdd("d", -90, CurrentDate)
CMMArray = Array("Inspcmm1", "Inspcmm2")
For CMM = LBound(CMMArray) To UBound(CMMArray)
With New Scripting.FileSystemObject
CMMFolder = "\\" & CMMArray(CMM) & "\cmm\21075A\OP290"
On Error GoTo ResumeIter
Set CMMFold = .GetFolder(CMMFolder)
For Each SetFolder In CMMFold.SubFolders
FFFile = SetFolder & "\21075A-030-FINALFLOWTOT " & SetFolder.Name & ".txt"
MsgBox SetFolder.Name
FileDate = FileDateTime(FFFile)
If FileDate >= KPCDate Then
LineIter = 0
With .OpenTextFile(FFFile, ForReading)
Do Until .AtEndOfStream
LineIter = LineIter + 1
LineData = .ReadLine
SplitData = Split(LineData)
'Extracting Serial Number
strSN.Add SplitData(0)
'Extracting Final Flow Value
strFF.Add SplitData(2)
Loop
.Close
End With
End If
Next SetFolder
End With
ResumeIter:
Next CMM
If strSN.Count = 0 Then
MsgBox "Neither Brown & Sharpe is online."
Exit Sub
Else
SheetRow = 12
For SNIter = 1 To strSN.Count Step 1
With Sheets("21075A KPC")
.Range("G" & SheetRow).Value = strSN.Item(SNIter)
.Range("H" & SheetRow).Value = strFF.Item(SNIter)
End With
SheetRow = SheetRow + 1
Next SNIter
LastRow = Sheets("21075A KPC").Range("G65536").End(xlUp).Row
With Sheets("21075A KPC")
'Calculate & Populate Means
.Range("H5") = WorksheetFunction.Average(.Range("H12:H" & LastRow))
'Calculate & Populate Standard Deviations
.Range("H6") = WorksheetFunction.StDev(.Range("H12:H" & LastRow))
'Populate 90-Day Reporting Period
.Range("F3") = KPCDate
.Range("F4") = CurrentDate
End With
End If
End Sub
All variables not declared in the above procedure have already been publicly declared. Thanks for looking into this. Please let me know if you need anything else from me.
I figured out that the SplitData array wasn't getting emptied and was consequently reaching its size limit, causing the Subscript Out of Range Error. I added the code line 'Erase SplitData()' after the code line 'Do Until .AtEndOfStream' and this emptied the SplitData array each time to prevent the accumulation of unnecessary data.
First of all let me all congratulate you on a superb forum! it's helped me Loads! so far with getting my little program working... and now I'm finally stuck.
I am attempting to automate Outlook to send tailored Offers to clients through a UserForm.
We offer 5 types of solutions and I don't know if the client will want 1 (DCF) or 2 (Top-Slice) or 3 (Ertragswert) or 4 (Belwert) or the 5 (Sachwert) of them. So I need a way for the code to check how many Checkboxes are ticked and then order them into a string (I've named it ValTyp) and separate them with comas and insert an "and"before the last. Say client wants 1, 3 and 5. The solution would be DCF, Ertragswert and Sachwert. So far I have my checkboxes all checking for values as follows:
Public iSach As String
Private Sub CKSach_Click()
Dim Sach As Boolean
Sach = CKSach.Value
If Sach = True Then
iSach = "Sachwert "
ValCount = ValCount + 1
Else
iSach = ""
ValCount = ValCount - 1
End If
End Sub
I have attempted at building an IF statement for a similar part which has 3 options and one is a must:
If (iRics <> "" And iBelSTD <> "" And iImmo <> "") Then
Standard = (iRics & ", " & iBelSTD & "und " & iImmo)
ElseIf (iBelSTD <> "" Or iImmo <> "") Then
Standard = (iRics & "und " & iImmo & iBelSTD)
Else
Stadard = iRics
End If
I am thinking of creating an array, with the length of ValCount... but I seem to be completely unable t get it to work:
Dim Services() As String
ReDim Services(0 To 4) As String
If iDCF <> "" Then
Services(0) = iDCF
End If
If iDCF <> "" Then
Services(1) = iCore
End If
If iDCF <> "" Then
Services(2) = iErtrag
End If
If iDCF <> "" Then
Services(3) = iSach
End If
If iDCF <> "" Then
Services(4) = iBelVT
End If
Debug.Print Services(0, 1, 2, 3, 4)
I get an runtime-error 9 index outside bounds.
I have no idea what to do and I haven't even got to how to include the commas and "and".
Any help at all will be much appreciated!
Thanks in advance!
Cliff
I would approach it like this: first, you store your checkboxes in a collection:
Dim cbs As New Collection
cbs.Add checkbox1
cbs.Add checkbox2
'...
cbs.Add checkbox5
Hence, you loop inside it to add the checked values into a new collection:
Dim myStr As String: myStr = ""
Dim cbsCheck As New Collection
'count "true"
For j = 1 To cbs.Count
If cbs(j).Value = True Then
cbsCheck.Add cbs(j)
End If
Next j
'hence you compose the string
If cbsCheck.Count = 0 Then
myStr = "No element selected"
ElseIf cbsCheck.Count = 1 Then
myStr = "You selected " & cbsCheck(1).Caption
Else
k = 1
myStr = "You selected "
While k < cbsCheck.Count
myStr = myStr & cbsCheck(k).Caption & ", "
k = k + 1
Loop
myStr = myStr & "and " & cbsCheck(k+1).Caption
End If
NOTE when you want to compose an array of elements of which you do NOT know the size in advance, in 95% of cases the object Collection is better than an object String Array.
You can use a collection instead of an array, which is most of the cases the better solution. If you really need an array for some reason, you can use the redim function to resize an array:
Example:
Dim myArray(3) As String
myArray(1) = "a"
myArray(2) = "b"
myArray(3) = "c"
ReDim myArray(4) As String
myArray(4) = "d"
You can also add a Preserve after ReDim to make sure the values won't get lost.
I have been wrestling with this for a day or so and am stumped.
Here is what I want to do:
I have a sheet with a complete list of the tab names in column A. Call this Total Tabs.
I have another sheet called "Reps No Longer Here". This is the target sheet where the contents of the individual tabs in the list are to be copied to.
I can put the names into an array (2D) and access the individual members, but I need to be able to compare the list name in the array to the tab names to find the correct tab. Once found, copy ALL the contents of that tab to "Reps No Longer Here" (next available row).
When it is finished the sheet "Reps No Longer Here" should be a complete list of all of the tabs listed in the array and sorted by the rep name.
How the heck do I do this? I'm really having a problem comparing the tabs to the list array and then copying all of the non-empty rows to the "Reps No Longer Sheet"
I appreciate all the help...
Jeff
ADDED:
Here is what I have so far, but it just isn't working:
Private Sub Combinedata()
Dim ws As Worksheet
Dim wsMain As Worksheet
Dim DataRng As Range
Dim Rw As Long
Dim Cnt As Integer
Dim ar As Variant
Dim Last As Integer
Cnt = 1
Set ws = Worksheets("Total Tabs")
Set wsMain = Worksheets("Reps No Longer Here")
wsMain.Cells.Clear
ar = ws.Range("A1", Range("A" & Rows.Count).End(xlUp))
Last = 1
For Each sh In ActiveWorkbook.Worksheets
For Each ArrayElement In ar 'Check if worksheet name is found in array
If ws.name <> wsMain.name Then
If Cnt = 1 Then
Set DataRng = ws.Cells(2, 1).CurrentRegion
DataRng.Copy wsMain.Cells(Cnt, 1)
Else: Rw = wsMain.Cells(Rows.Count, 1).End(xlUp).Row + 1
'don't copy header rows
DataRng.Offset(1, 0).Resize(DataRng.Rows.Count - 1, _
DataRng.Columns.Count).Copy ActiveSheet.Cells(Rw, 1)
End If
End If
Cnt = Cnt + 1
Last = Last + 1
Next ArrayElement
Next sh
End Sub
UPDATE - 7/3/14
This is the modified code. I'll highlight the line that is giving syntax error.
Sub CopyFrom2To1()
Dim Source As Range, Destination As Range
Dim i As Long, j As Long
Dim arArray As Variant
Set Source = Worksheets("Raw Data").Range("A1:N1")
Set Dest = Worksheets("Reps No Longer Here").Range("A1:N1")
arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))
For i = 1 To 100
For j = 1 To 100
If Sheets(j).name = arArray(i, 1) Then
Source.Range("A" & j).Range("A" & j & ":N" & j).Copy ' A1:Z1 relative to A5 for e.g.
***Dest.Range("A" & i ":N" & i).Paste***
Exit For
End If
Next j
Next i
End Sub
The solution to a very similar problem was posted here yesterday by me. Have a look at the main loop in the code:
Sub CopyFrom2TO1()
Dim Source as Range, Destination as Range
Dim i as long, j as long
Set Source = Worksheets("Sheet1").Range("A1")
Set Dest = Worksheets("Sheet2").Range("A2")
for i = 1 to 100
for j = 1 to 100
if Dest.Cells(j,1) = Source.Cells(i,1) then
Source.Range("A" & j).Range("A1:Z1").Copy ' A1:Z1 relative to A5 for e.g.
Dest.Range("A"&i).Paste
Exit For
end if
next j
next i
End Sub
This would need slight modifications for your purpose, but it essentially does the same thing. Compares a column to a another column and copies wherever a match takes places.
Unable to find how to code: If Cell Value Equals Any of the Values in a Range
I have some VBA I am wanting to use to update and add data to a table on an SQL server. I have been muddling through with limited knowledge of this functionality within VBA all day, searching various sites and not really getting any answers to make things click into place and not getting any response when posting it elsewhere. Hopefully I can get this solved here.
So, I have the following code that I have cobbled together:
Sub connectsqlserver()
Dim conn As ADODB.Connection
Dim recset As ADODB.Recordset
Set conn = New ADODB.Connection
Set recset = New ADODB.Recordset
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim msgstrng As String
Dim newstring As String
If conn.State <> 0 Then
conn.Close
End If
With conn
.ConnectionString = "Driver={SQL Server};server=sage500;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.ConnectionTimeout = 5
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 1 To Sheets("Changes").Range("A1").Value
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
'Do something
Next i
Sheets("Changes").Rows("3:" & i + 2).Delete xlUp
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 1 To Sheets("New").Range("A1").Value
newstring = ""
For k = 1 To 38
If k = 38 Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
Debug.Print (newstring)
With recset
.AddNew (newstring)
.Update
End With
Next j
Sheets("New").Rows("3:" & j + 2).Delete xlUp
Else
j = 0
End If
recset.Close
conn.Close
If i = 0 And j = 0 Then
msgstring = "No Changes/New Data to add"
Else
If i = 0 And j <> 0 Then
msgstring = "No Changes and " & j & " New Customers added"
Else
If i <> 0 And j = 0 Then
msgstring = i & " Changes and no New Customers added"
Else
msgstring = i & " Changes and " & j & " New Customers added"
End If
End If
End If
End Sub
Part 1: This currently throws out an error at "With recset.AddNew..." (3001) saying that arguments are of the wrong type. The table it is going to is formatted as nvarchar(255) and all the data is formatted as text in the various fields so I am not entirely sure whats happening there.
Part 1 code:
If lastrow <> 0 Then
For j = 1 To lastrow
For k = 1 To lastfield
If k = lastfield Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
With recset
.AddNew (newstring)
.Update
End With
Next j
End If
Part 2: As my knowledge of VBA for ADODB connections is awful at best, I cannot figure out how to continue once I have found the row I require, hence the "'Do something" line. What I need this to do is find the record matched from column B in the "Changes" excel table and then edit that row in the SQL table to match it. I can't figure out how to do this though.
Part 2 code:
If lastrow <> 0 Then
For i = 1 To lastrow
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
' Do something
Next i
End If
EDIT: I have this from the debug.print which may help some people visualise this a bit more:
"23/07/13","TEST123","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test"
This is for a full line (so therefore the Field List should not be required as this is data for every column in the correct order).
From what you posted, I believe you've been trying to concatenate all the values into a string separated by ','. (correct me if I'm wrong)
This answer is only useful if you wanted to append new data, if you want to find a specific record in the database and update it then its a completely different story.
The "Add New" method takes in two arguments.
The list of fields in array format
The list of values in array format
Unless you have only one field or one value to add you should put them into array before using the "Add New" method.
A possible way of constructing the arrays:
For i = 0 to count_of_fields
aryFields(i) = field_value
Next
For i = 0 to count_of_values
aryValues(i) = value
Next
recset.AddNew aryFields,aryValues
recset.Update
Let me know if that helps!
Will post this now actually instead of Monday or else I may forget.
Ended up being the neatest solution as working with arrays in this case seemed to fail a lot and they are a lot harder to debug. This at least made it a lot simpler.
Also, was good finding out that once you have found the row (my part 2 question), that it is in fact the same process as with .addnew (which was what I was not sure of)
With conn
.ConnectionString = "Driver={SQL Server};server=sage;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 3 To LastRow
With recset
.Find "Col2 = " & "'" & Sheets("Changes").Range("B" & i) & "'"
For k = 1 To 38
strField = Sheets("Changes").Cells(2, k).Value
varValue = Sheets("Changes").Cells(i, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next i
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 3 To LastRow
With recset
.AddNew
For k = 1 To 38
strField = Sheets("New").Cells(2, k).Value
varValue = Sheets("New").Cells(j, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next j
Else
j = 0
End If
... etc
So anyway, thanks to all that tried helping on here. I still cannot understand why arrays were not working though.