I am attempting to insert data from Excel to a SQL datbase by means of VBA. I am using the following structure in Excel:
I am using the following code:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim p As Integer
Dim product As String
Dim version As String
Dim opt As String
Dim visible As String
Excel.Worksheets("Blad2").Select
i = 3
Do Until IsEmpty(Cells(i, 1))
opt = ActiveSheet.Cells(i, 1)
p = 3
Do Until IsEmpty(Cells(1, p))
product = ActiveSheet.Cells(1, p)
version = ActiveSheet.Cells(2, p)
visible = ActiveSheet.Cells(i, p)
Debug.Print product & version & opt & visible
p = p + 1
Loop
i = i + 1
Loop
End Sub
The result of running the script is as follows:
product#1 version#1 option#1 0
product#1 version#2 option#1 1
option#1
While I want it to result in:
product#1 version#1 option#1 0
product#1 version#2 option#1 1
product#1 version#1 option#2 0
product#1 version#2 option#2 0
Could someone help me out?
This is something that should work for the input of this:
bringing this:
product1 version1 option1 0
product1 version2 option1 1
product1 version1 option2 0
product1 version2 option2 0
Option Explicit
Public Sub TestMe()
Dim k As Long
Dim i As Long
Dim p As Long
Dim product As String
Dim version As String
Dim opt As String
Dim visible As String
With ActiveSheet
i = 3
Do Until IsEmpty(.Cells(i, 1))
p = 3
k = 0
Do Until IsEmpty(.Cells(1, p))
opt = .Cells(i, 1)
product = .Cells(1, p)
visible = .Cells(i, p)
version = .Cells(2, 3 + k)
k = k + 1
Debug.Print product & " " & version & " " & opt & " " & visible
p = p + 1
Loop
i = i + 1
Loop
End With
End Sub
In general, consider using better names for the variables and using Long instead of Integer.
I might be missing something but seems the variable visible is stucked with row 3 .Cells(3, p), that's why it only inserting Option 1 and disregarding the first loop.
try to change it with visible = ActiveSheet.Cells(i, p)
Edit: You said that is it not working, but seems when i tested it, I am getting the right result.
There's a possibility that when SQL string to be executed is the issue here.
Related
I have a data-set with Product 1 in Column A and Product 2 in Column B.
I would like to build a new table which counts the number of rows on which every possible combination of Product 1 and Product 2 occur. (Preferably regardless of the order in which they occur, but I can clean that up after if needed)
I can build this manually, however I am dealing with hundreds of possible combinations and would like to automate the process with a macro or any other recommendations anyone has.
Example of raw data:
Product 1 Product 2
Cheese Apple
Crackers Sausage
Cheese Sausage
Crackers Sausage
Apple Crackers
Apple Cheese
Cheese Apple
Cherry Apple
Example of new summarized table:
Combo | Count of Combo Occurrences
Cheese and Apple | 3
Cheese and Sausage | 1
Cherry and Apple | 1
Crackers and Sausage| 2
Apple and Crackers | 1
Thanks in advance
Late to the party but your question seemed like a fun exercise. For kicks I decided to add an extra layer of complexity by writing it to use any size range & outputting the results to a specified range (or sheet).
Sub Test()
Call CountUniqueCombinations(Range("A2:D7"), Range("F2"))
End Sub
Private Sub CountUniqueCombinations(ByVal SourceRange As Range, ByVal DestinationRange As Range)
Dim oRowIndex As Long
Dim oColIndex As Long
Dim oRow As New Collection
For oRowIndex = 0 To SourceRange.Rows.Count - 1
oValue = ""
Set oRow = Nothing
' Sort Current Row (Output to String)
For oColIndex = 1 To SourceRange.Columns.Count
oRow.Add SourceRange(oRowIndex + 1, oColIndex).Value
Next
oValue = SortCollection(oRow)
' See if Sorted row already Exists if so +1
Dim oDestRowIndex As Long
Dim oFound As Boolean
oFound = False
For oDestRowIndex = 1 To DestinationRange.Rows.Count
If DestinationRange(oDestRowIndex, 1).Value = oValue Then
DestinationRange(oDestRowIndex, 2).Value = CInt(DestinationRange(oDestRowIndex, 2).Value) + 1
oFound = True
Exit For
End If
Next
' if Sorted row doesn't exist add it
If Not oFound Then
DestinationRange(DestinationRange.Rows.Count, 1) = oValue
DestinationRange(DestinationRange.Rows.Count, 1).Offset(0, 1) = 1
Set DestinationRange = DestinationRange.Resize(DestinationRange.Rows.Count + 1, 1)
End If
Next
End Sub
Private Function SortCollection(ByVal oCollection As Collection) As String
Dim oX As Long, oY As Long
Dim oTempValue As String
For oX = 1 To oCollection.Count - 1
For oY = oX + 1 To oCollection.Count
If oCollection(oX) > oCollection(oY) Then
oTempValue = oCollection(oY)
oCollection.Remove (oY)
oCollection.Add oTempValue, oTempValue, oX
End If
Next
Next
For oX = 1 To oCollection.Count
If oCollection.Item(oX) <> "" Then
SortCollection = SortCollection & oCollection.Item(oX) & " & "
End If
Next
SortCollection = Left(SortCollection, Len(SortCollection) - 3)
End Function
Just in case some poor soul will need this in VBA:
Option Explicit
Sub ComboOccurences()
' Remember to check Microsoft Scripting Runtime in References!
Dim dict As Scripting.Dictionary
Dim i As Integer, r As Integer, LastRow As Integer
Dim ColAB As String, ColBA As String
Set dict = New Scripting.Dictionary
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
ColAB = Range("A" & i).Value & " and " & Range("B" & i).Value
ColBA = Range("B" & i).Value & " and " & Range("A" & i).Value
If Not dict.Exists(ColAB) And Not dict.Exists(ColBA) Then
dict.Add (ColAB), 1
ElseIf dict.Exists(ColAB) Then
dict(ColAB) = dict(ColAB) + 1
ElseIf dict.Exists(ColBA) Then
dict(ColBA) = dict(ColBA) + 1
End If
Next
r = 2
For i = 0 To dict.Count - 1
Range("D" & r).Value = dict.Keys(i)
Range("E" & r).Value = dict.Items(i)
r = r + 1
Next
End Sub
Result:
Hope this will help somebody!
I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B
Row1 ABC ABD ABE ABF | CODE1
Row2 BCA DBA EBA FBA | CODE2
Row3 TEA BEF | CODE3
The result would be:
A B
ABC CODE1
ABD CODE1
ABE CODE1
ABF CODE1
BCA CODE2
DBA CODE2
EBA CODE2
FBA CODE2
TEA CODE3
BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2)
' The result will be ...
"EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.
I like iterating over cells for problems like this post.
' code resides on input sheet
Sub ParseData()
Dim wksOut As Worksheet
Dim iRowOut As Integer
Dim iRow As Integer
Dim asData() As String
Dim i As Integer
Dim s As String
Set wksOut = Worksheets("Sheet2")
iRowOut = 1
For iRow = 1 To UsedRange.Rows.Count
asData = Split(Trim(Cells(iRow, 1)), " ")
For i = 0 To UBound(asData)
s = Trim(asData(i))
If Len(s) > 0 Then
wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
wksOut.Cells(iRowOut, 2) = s
iRowOut = iRowOut + 1
End If
Next i
Next iRow
MsgBox "done"
End Sub
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
Public Sub FixIt()
Dim fromSheet, toSheet As Excel.Worksheet
Dim fromRow, toRow, k As Integer
Dim code As String
Set fromSheet = Me.Worksheets(1)
Set toSheet = Me.Worksheets(2)
' Ignore first row
fromRow = 2
toRow = 1
Dim outsideArr() As String
Dim insideArr() As String
Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""
' Split on the pipe
outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")
' Split left of pipe, trimmed, on space
insideArr = Split(Trim(outsideArr(0)), " ")
' Save the code
code = Trim(outsideArr(UBound(outsideArr)))
' Skip first element of inside array
For k = 1 To UBound(insideArr)
toSheet.Cells(toRow, 1).Value = insideArr(k)
toSheet.Cells(toRow, 2).Value = code
toRow = toRow + 1
Next k
fromRow = fromRow + 1
Loop
End Sub
Let me try as well using Dictionary :)
Sub Test()
Dim r As Range, c As Range
Dim ws As Worksheet
Dim k, lrow As Long, i As Long
Set ws = Sheet1 '~~> change to suit, everything else as is
Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In r
If Not .Exists(c.Value) Then
.Add c.Value, Split(Trim(c.Offset(0, -1).Value))
End If
Next
ws.Range("A:B").ClearContents
For Each k In .Keys
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lrow = 1 Then i = 0 Else i = 1
ws.Range("A" & lrow).Offset(i, 0) _
.Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
Next
End With
End Sub
Above code loads all items in Dictionary and then return it in the same Range. HTH.
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "CodeData"
Option Explicit
Private pData As String
Private pCode As String
Property Get Data() As String
Data = pData
End Property
Property Let Data(Value As String)
pData = Value
End Property
Property Get Code() As String
Code = pCode
End Property
Property Let Code(Value As String)
pCode = Value
End Property
Then put the following code into a Regular module:
Option Explicit
Sub ParseCodesAndData()
Dim cCodeData As CodeData
Dim colCodeData As Collection
Dim vSrc As Variant, vRes() As Variant
Dim V As Variant
Dim rRes As Range
Dim I As Long, J As Long
'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")
'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))
'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), " ")
For J = 0 To UBound(V)
Set cCodeData = New CodeData
cCodeData.Code = Trim(vSrc(I, 2))
cCodeData.Data = Trim(V(J))
colCodeData.Add cCodeData
Next J
Next I
'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
Set cCodeData = colCodeData(I)
vRes(I, 1) = cCodeData.Data
vRes(I, 2) = cCodeData.Code
Next I
'Write array to worksheet
Application.ScreenUpdating = False
rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes
Application.ScreenUpdating = True
End Sub
Here is the solution I devised with help from above. Thanks for the responses!
Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("B1:C" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
What i am doing here in my code is, I have
ID Value
1 a
1 b
1 c
2 a
2 b
and I am getting
ID Value
1 a,b,c
2 a,b
I could just do it in the SQL using STUFF keyword but I have decided to go with this
In the code section of the report I have written
Private CurrGroupBy As String = String.Empty
Private ConcatVal As String = String.Empty
Public Function AggConcat(GroupBy as String, ElementVal as String) as String
If CurrGroupBy = GroupBy Then
If InStr(ConcatVal, ElementVal,0) = 0 Then
ConcatVal = Trim(ConcatVal) & ", " & ElementVal
End If
Else
CurrGroupBy = GroupBy
ConcatVal = ElementVal
End If
Return ConcatVal
End Function
and in one of the rows I am using this expression below
=RunningValue(Code.AggConcat(Fields!Id.Value, Fields!Theme.Value), Last, "DataSet1")
This is working perfectly if view the report and export it to PDF. But, when I export it to Excel then the result I am getting is
ID Value
1 a
1 a,b
1 a,b,c
2 a
2 a,b
What am I doing wrong here ?
When I tried to reproduce what was explained above, both the report viewer and excel produced the described unexpected scenario.
Although in order to achieve the desired output i added a report group and removed the =(Details) group this worked both in Report View and when exporting to Excel.
The solution ended up looking like:
I have no clue. If the starting code is in excel you could modify this code to do what you want. I found this a long time ago. if it is not what you’re looking for ignore it.
Sub ConcatNotesTextV2()
' hiker95, 04/14/2012
' http://www.mrexcel.com/forum/showthread.php?t=628561
Dim r As Long, lr As Long, nr As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
n = Application.CountIf(Columns(1), Cells(r, 1).Value)
If n = 1 Then
'do nothing
ElseIf n > 1 Then
Range("B" & r) = Join(Application.Transpose(Range("B" & r & ":B" & (r + n) - 1)), ,)
Range("A" & r).Offset(1).Resize(n - 1).ClearContents
End If
r = r + n - 1
Next r
On Error Resume Next
Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells (xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Sub Add_sumf()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
For Each y In bb.Range("A:A")
On Error GoTo Label
If UCase(bb.Cells(j, "A").Value) <> "" Then
cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), aa.Range("B:B"), UCase(bb.Cells(1, k).Value), aa.Range("G:G"), UCase(bb.Cells(j, "A").Value))
bb.Cells(j, k).Value = TimeValue(cellDate1)
cellDate1 = TimeValue("00:00:00")
bb.Cells(j, k).NumberFormat = "[h]:mm:ss"
On Error GoTo Label
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
I am using above code to add time duration based upon value of two other columns but I always get 00:00:00 as result.
if i use below code i get the answer but its too slow very slow
Sub add_it_time()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
'MsgBox bb.Cells(1, k).Value
For Each y In bb.Range("A:A")
On Error GoTo Label
' MsgBox UCase(bb.Cells(j, "A").Value)
If UCase(bb.Cells(j, "A").Value) <> "" Then
For Each x In aa.Range("F:F")
On Error Resume Next
If UCase(aa.Cells(i, "B").Value) = UCase(bb.Cells(j, "A").Value) Then
' MsgBox aa.Cells(i, "F").Text
' total = total + Int(get_Second(aa.Cells(i, "F").Text))
If UCase(aa.Cells(i, "G").Value) = UCase(bb.Cells(1, k).Value) Then
'MsgBox aa.Cells(i, "F").Text
cellDate1 = cellDate1 + TimeValue(aa.Cells(i, "F").Value)
End If
End If
i = i + 1
Next
i = 3
On Error GoTo Label
bb.Cells(j, k).NumberFormat = "h:mm:ss"
bb.Cells(j, k).Value = WorksheetFunction.Text(cellDate1, "[hh]:mm:ss")
total = 0
cellDate1 = 0
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
The source column which contains date is of general formatt
I am new to VBA macros
UPDATED SOLUTION:
After discussion in chat with OP it was decided that pure formula solution is fine - below are formulas / actions to do on the separate sheet starting A1:
Row A will be resulting table header: in A1 I added Agent Name / Release Code, and starting B1 there's a list of all available Release Code values (easily got using Remove Duplicates).
I defined the following named ranges for the simplicity and effectiveness (since initial data is NOT static): AgentNames=OFFSET('Agent State'!$B$2,0,0,COUNTA('Agent State'!$B:$B)-1,1) - this will return the range of names on the initial sheet excluding the header; TimeInStateData=OFFSET(AgentNames,0,4) and ReleaseCodes=OFFSET(AgentNames,0,5) as shifted AgentNames range.
In column A we should obtain the list of names, which should be unique, so select in column A any number of cells which is NOT less that number of unique names - for the sample I used A2:A51, and type that formula: =IFERROR(INDEX(AgentNames,SMALL(IF(MATCH(AgentNames,AgentNames,0)=ROW(INDIRECT("1:"&ROWS(AgentNames))),MATCH(AgentNames,AgentNames,0),""),ROW(INDIRECT("1:"&ROWS(AgentNames))))),"") and press CTRL+SHIFT+ENTER instead of usual ENTER - this will define a Multicell ARRAY formula and will result in curly {} brackets around it (but do NOT type them manually!).
B2: =IF(OR($A2="",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))=0),"",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))) - normal formula, which will return empty value for either empty name or zero time.
Copy formula from B2 to the whole table.
Remarks:
Resulting range for the sum of time values should be formatted as Time.
If the list of names should be expanded in the future - repeat step 3 for the new range, but do NOT drag the formula down - this will result in You cannot change part of an array error.
Sample file: https://www.dropbox.com/s/quudyx1v2fup6sh/AgentsTimeSUM.xls
INITIAL ANSWER:
Perhaps that's too simple and obvious, but at a glance I don't understand why you have that line of code:
cellDate1 = TimeValue("00:00:00")
right after your SUMIFS: cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), ...
Try to remove the first one where you assign zeros to cellDate1.
i need help with the following excel and what looks like a VBA problem.
The idea here is to generate all the possible combination (without repetition) in each grouping.
INPUT
COLUMN A | COLUMN B
A | 1
X | 1
D | 1
C | 2
E | 2
OUTPUT
COLUMN A | COLUMN B
A | X
A | D
X | D
X | A
D | A
D | X
C | E
E | C
What I managed to do.... how do i let it run only if the data is in the same group.
Option Explicit
Sub Sample()
Dim i As Long, j As Long
Dim CountComb As Long, lastrow As Long
Application.ScreenUpdating = False
CountComb = 0: lastrow = 1
For i = 1 To 10: For j = 1 To 10
Range("G" & lastrow).Value = Range("A" & i).Value & "/" & _
Range("B" & j).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
Next: Next
Application.ScreenUpdating = True
End Sub
see below. Note you need to add the reference Microsoft Scripting Runtime in Tools >> References. Change the Range("A1:A5") to either a dynamic named range or static range and the routine will handle the rest for you. It displays the results starting in G1 but you can also change this / make dynamic as an offset from the data range. Up to you.
Option Explicit
Option Base 1
Dim Data As Dictionary
Sub GetCombinations()
Dim dataObj As Variant
Dim returnData As Variant
Set Data = New Dictionary
Dim i As Double
dataObj = Range("A1:B5").Value2
' Group Data
For i = 1 To UBound(dataObj) Step 1
If (Data.Exists(dataObj(i, 2))) Then
Data(dataObj(i, 2)) = Data(dataObj(i, 2)) & "|" & dataObj(i, 1)
Else
Data.Add dataObj(i, 2), dataObj(i, 1)
End If
Next i
' Extract combinations from groups
returnData = CalculateCombinations().Keys()
Range("G1").Resize(UBound(returnData) + 1, 1) = Application.WorksheetFunction.Transpose(returnData)
End Sub
Private Function CalculateCombinations() As Dictionary
Dim i As Double, j As Double
Dim datum As Variant, pieceInner As Variant, pieceOuter As Variant
Dim Combo As New Dictionary
Dim splitData() As String
For Each datum In Data.Items
splitData = Split(datum, "|")
For Each pieceOuter In splitData
For Each pieceInner In splitData
If (pieceOuter <> pieceInner) Then
If (Not Combo.Exists(pieceOuter & "|" & pieceInner)) Then
Combo.Add pieceOuter & "|" & pieceInner, vbNullString
End If
End If
Next pieceInner
Next pieceOuter
Next datum
Set CalculateCombinations = Combo
End Function