I'm a beginner with VBA and I'm wondering how to copy a select statement to array. how can i do?
ı tried to do something but i couldn't complite.
Private Sub Komut485_Click()
Dim a() As String
'Dim a() As Integer
'abc = Me.talep_kayit_no.Value
'MsgBox abc
For sayac = 1 To 5
a(sayac) = "SELECT [3_gh_odemeler].[gh_no] FROM 3_gh_odemeler WHERE [3_gh_odemeler].[gh_no] =" & Me.talep_kayit_no.Value & ";"
sayac = sayac + 1
MsgBox a(1)
Next
End Sub
I thought arrays always start at 0 and would therefore use the first position(0) as the right position.
Dim intArraySize as integer
dim a() as string
intArraySize =5
redim a(intArraySize)
For sayac = 0 To intArraySize
a(sayac-1) = "SELECT [3_gh_odemeler].[gh_no] FROM 3_gh_odemeler WHERE [3_gh_odemeler].[gh_no] =" & Me.talep_kayit_no.Value & ";"
sayac = sayac + 1
MsgBox a(1)
Next
End Sub
Related
I'm writing on a timesheet printing code.
In a table, I was provided with all staff names (column A) and (if timesheet needs to be printed) their initials (column E). If staff doesn't need timesheet, they provided "XXX" as initials.
I now want to print all staff which have initials other than "XXX".
I can print individual timesheet or even the array of all worksheets after "print", but I can't read the array into VBA to print only the ones I need.
Is it because worksheet "XXX" doesn't exist?
What is missing from my code?
Private Sub CommandButton2_Click()
'check if date is a Monday
If Weekday(Range("B2").Value) <> 2 Then
MsgBox "Please alter the date to a Monday.", 0, "Date selected is not a Monday."
Exit Sub
End If
Dim PrintRng As Range
Dim SavePDFT As String
Dim shtArray() As String
Dim i As Integer
Dim x As Long
Dim ws As Worksheet
Set PrintRng = Range("A1:Q34")
SavePDFT = ThisWorkbook.Path & "Timesheets_" & Range("E40").Value & "_" & Format(Now(), "yymmddhhmmss")
x = Worksheets("print").Index
' Enter the sheet names into an array
i = 0
For Each ws In ActiveWorkbook.Worksheets
With ws
If .Index > x Then
ReDim Preserve shtArray(i)
Debug.Print ws.Name
shtArray(i) = ws.Name
'MsgBox "" & ActiveWorkbook.Worksheets(shtArray(i)).Name
i = i + 1
End If
End With
Next ws
Dim TSarray() As Variant
elements = 10 ' needs to be altered
ReDim TSarray(1 To elements) As String
counter = 1
For counter = 1 To elements
f = 4 + counter
If Cells(f, 5).Value <> "XXX" Then
TSarray(counter) = Cells(f, 5).Value
End If
Next counter
'counter = 1 'this loop shows what was filled in
' While counter <= UBound(TSarray)
' MsgBox TSarray(counter)
' counter = counter + 1
' Wend
Sheets(TSarray).Select 'working with Sheets(shtArray).Select, but I don't want to print all worksheets, just selected ones
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
With ActiveSheet.PageSetup
.PrintArea = PrintRng
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=SavePDFT, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ActiveSheet.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
End Sub
So I have this list that is X rows long.
Each has 5 columns: Equipment, Type, Material, Size and Price this is in the Sheet2.
I also have a database in sheet1 with the same column filled in. I have written a code in VBA that for each row in Sheet2 I can fill in Equipment, Type, Material and Size and it will search in the database in sheet1 the matching price for those criteria and past this under the column Price in Sheet2.
Now the problem that I have is if I for example filled in row 1, row 2 and row 3 after each other it works and gives me the price but if I later want to change the variables in row 1 or 2 it doesn't change/update the Price but it still works for row 3 and forward.
How do I make it so that it does change/Update the price in row 1 and 2 if I change the variables there.
my code:
Option Explicit
Public r As Long
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
Dim c As Long, LR As Long
LR = Cells(Rows.Count, 2).End(xlUp).Row
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
For r = r - 29 To LR
c = 5
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(r, c).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(r, c).Value = "Data Not Found!"
End If
Next r
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
Now to update everytime I change something in Sheet2 I just wrote this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call cmdSearch_Click
End Sub
So again my question how do I update/change the price if I change a variable in row 1 or row 2 if row 3 was the last row that was used in the sheet.
This is the datbase that I am using:
This is Sheet2:
1) One immediate problem I see that will cause your issue (and there may be more, but I don't have time to dissect so much at this moment), is that the initial loop:
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
is not doing what you may expect. At the end of this loop you only have set the values for the last row of data (I suspect row 3) to pass into your query.
You'll need to write your queries inside this loop as well so that the query is run for each set of criteria in each line.
For example:
For r = 1 to LR
c = 2
With Worksheets("Summary")
'code to set criteria
End With
'code to download data price
'code to stick data and price in summary tab
Next r
2) Also, make sure to qualify all your objects. The line
LR = Cells(Rows.Count, 2).End(xlUp).Row
may return different results if the sheet you desire to be active is not actually active. Better to say this, for example, and leave out guess works:
LR = Worksheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row
3) Using Worksheet_SelectionChange will fire your code every time you move from one to another in your worksheet. If you want to only fire the code when you make a change to the criteria in your data, use Worksheet_Change instead. You can also define which specific cells being changes will run the code as well.
I want to select a array of sheets using the Sheets(Array()) method. The sheets I want to select are named in the cells of my workheet Printlijst. The sheetnames are listed form column D to K.
Not all cells are filled so if I use the folowing function
This is what the sheet looks like:
http://i.stack.imgur.com/uJqZc.jpg
And this is the code:
Sub PDF_maken()
Dim ws As Worksheet
Dim LR As Long
Dim r As Range
Dim Mypath As String
Dim strarray As String
Set ws = ActiveWorkbook.Worksheets("Printlijst")
LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
For Each r In ws.Range("B20:B20").Cells
If Not IsEmpty("B" & r.Row) Then
Mypath = ws.Range("B" & r.Row).Text
colCheck = 4
Do Until Cells(r.Row, colCheck) = ""
strarray = strarray & IIf(colCheck > 4, ",", "") & Cells(r.Row, colCheck).Value
colCheck = colCheck + 1
Loop
ActiveWorkbook.Sheets(strarray).Select
ActiveWorkbook.SelectedSheets.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Mypath & ws.Range("C" & r.Row).Text & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Next r
End Sub
The errors happens when more than one sheet must be selected
When I use the errorcheck strarray is "2450,2451,2452,2453,2454,2455,2456,2457"
You cannot use strarray in ActiveWorkbook.Sheets(strarray). It is expecting a single sheet name or a collection of sheets in array.
Is this what you are trying?
'
'~~> Rest of your code
'
Dim strarray As String
Dim MyAr As Variant
Do Until Cells(r.Row, colCheck) = ""
strarray = strarray & IIf(colCheck > 4, ",", "") & Cells(r.Row, colCheck).Value
colCheck = colCheck + 1
Loop
If InStr(1, strarray, ",") Then
MyAr = Split(strarray, ",") '<~~ This is where we are creating an actual array
ActiveWorkbook.Sheets(MyAr).Select
Else
ActiveWorkbook.Sheets(strarray).Select
End If
'
'~~> Rest of your code
'
NOTE: BTW, you should avoid using .Select and directly perform the operation on those sheet(s). You may want to see How to avoid using Select in Excel VBA macros
I am using the following code to chop up a column of comma-separated lists and to return each entry in a new row:
Sub SliceNDice()
'
' Splits the locations cells according to commas and pushes to new rows
' Code courtesy of brettdj (http://stackoverflow.com/questions/8560718/split-comma-separated-entries-to-new-rows)
'
Dim objRegex As Object
Dim x
Dim Y
Dim lngRow As Long
Dim lngCnt As Long
Dim tempArr() As String
Dim strArr
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "^\s+(.+?)$"
'Define the range to be analysed
x = Range([a1], Cells(Rows.Count, "c").End(xlUp)).Value2
ReDim Y(1 To 3, 1 To 1000)
For lngRow = 1 To UBound(x, 1)
'Split each string by ","
tempArr = Split(x(lngRow, 3), ",")
For Each strArr In tempArr
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
Next
Next lngRow
'Dump the re-ordered range to columns E:G
[e1].Resize(lngCnt, 3).Value2 = Application.Transpose(Y)
End Sub
While this code works perfectly, it has a fatal flaw in that any double-commas in the cells of column C will result in blank cells pushed to the new rows in column G.
Does anyone know how to edit the code so that it does not create new rows with empty cells in column G, but skips them and enters the next rows in their places as if the superfluous commas were never included in column C at all?
Just test for the string length of strArr as the first operation inside the For Each strArr In tempArr loop.
For Each strArr In tempArr
If CBool(Len(strArr)) Then
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
End If
Next strArr
You could loop on the occurence of double comma to clean up the input as opposed to fixing the output, here is a working example:
Text in A1: Hello,,World,This,,Is,,,,,,,A,,Test
Sub TestString()
Dim MyString As String
MyString = Range("A1").Text
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
MsgBox MyString
End Sub
You would do this just before splitting
If you want it as a function (would be better in your case) do this:
Function FixDoubleComma(MyString As String)
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
FixDoubleComma = MyString
End Function
Then replace this in your code:
tempArr = Split(x(lngRow, 3), ",")
With this:
tempArr = Split(FixDoubleComma(x(lngRow, 3)), ",")
I have a little sample that solves blanks everywhere
Sub RemoveBlanks()
Dim mystr As String
Dim arrWithBlanks() As String
Dim arrNoBlanks() As String
Dim i As Integer
mystr = ",tom,jerry, ,,spike,," 'Blanks everywhere (beginning, middle and end)
arrWithBlanks = Split(mystr, ",")
ReDim arrNoBlanks(0 To 0)
Debug.Print "Array with blanks:"
'Loop through the array with blanks
For i = LBound(arrWithBlanks) To UBound(arrWithBlanks)
'Check if there is a blank (or element with spaces only)
If Trim(arrWithBlanks(i)) = "" Then
Debug.Print i & " (blank)"
Else
Debug.Print i & " " & arrWithBlanks(i)
If arrNoBlanks(UBound(arrNoBlanks)) <> "" Then ReDim Preserve arrNoBlanks(0 To UBound(arrNoBlanks) + 1)
arrNoBlanks(UBound(arrNoBlanks)) = arrWithBlanks(i)
End If
Next i
Debug.Print "Array with NO blanks:"
For i = LBound(arrNoBlanks) To UBound(arrNoBlanks)
Debug.Print i & " " & arrNoBlanks(i)
Next i
End Sub
Everything will be displayed in the immediate window (Press Ctrl + G to show it)
The result will look like this:
Array with blanks:
0 (blank)
1 tom
2 jerry
3 (blank)
4 (blank)
5 spike
6 (blank)
7 (blank)
Array with NO blanks:
0 tom
1 jerry
2 spike
I would like to count the numbers of "c" inside my array txt. The transition for 1 to 0 means a new cycle, thats why i put a "c" whenever this happen. In this code I get type mismatch when i try to count the "c". Thank you for the help.
Sub CopyColumn()
Dim finalrow As Long
Dim i As Variant
ReDim arrayciclos(0)
Dim str As String
Dim ciclos As Variant
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
arrayciclos(UBound(arrayciclos)) = Range("J" & i)
ReDim Preserve arrayciclos(UBound(arrayciclos) + 1)
Next i
For i = LBound(arrayciclos) To UBound(arrayciclos)
txt = txt & arrayciclos(i) ' & vbCrLf
Next i
MsgBox txt
Do While InStr(txt, "10")
txt = Replace(txt, "10", "c")
Loop
MsgBox txt
ciclos = 0: i = 0
For i = 0 To finalrow
If txt(i) = "c" Then ' i have Type Mismatch here
ciclos = ciclos + 1
End If
Next
MsgBox (ciclos)
End Sub
Based on your posted code, the txt variable is not explicitly declared. In addition, the implicit declaration of variant becomes a type of string when you use the second loop to concatenate the values together with txt = txt & arrayciclos(I). You should modify the code to include the Option Explicit statement to check for undeclared variables. In addition you should use the Mid function to perform the checks for the "c" character in your final loop.
Option Explicit ' <-- added to check for undeclared variables
Sub CopyColumn()
Dim finalrow As Long
Dim i As Variant
ReDim arrayciclos(0)
Dim str As String ' <-- unused variable problaby should have been named txt in your example
Dim ciclos As Variant
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
finalrow = 9
For i = 2 To finalrow
arrayciclos(UBound(arrayciclos)) = Range("J" & i)
ReDim Preserve arrayciclos(UBound(arrayciclos) + 1)
Next i
For i = LBound(arrayciclos) To UBound(arrayciclos)
str = str & arrayciclos(i) ' & vbCrLf
Next i
MsgBox str
Do While InStr(str, "10")
str = Replace(str, "10", "c")
Loop
MsgBox str
ciclos = 0: i = 0
For i = 0 To finalrow
If Mid(str, i + 1, 1) = "c" Then ' <-- changed to Mid(string, start, len)
ciclos = ciclos + 1
End If
Next
MsgBox (ciclos)
End Sub
I think you are using too many loops. If you want to loop through the array txt To count the number of "c" then you only need to do
Dim MyArray As Variant
dim count as integer
'specify your range. For example
MyArray = Range("BS27:DS50000")
'Loop through and find all occurrences of "c"
For i = LBound(MyArray) To UBound(MyArray)
For j = LBound(MyArray, 2) To UBound(MyArray, 2)
If MyArray(i, j) = "c" Then count = count + 1
Next j
Next i
msgbox count
If "c" is not single within each cell then replace If MyArray(i, j) = "c" with If MyArray(i, j) = "c" and put asterix within both sides of "c" like asterix c asterix. This will be a character match