I have a private function that is designated to declare "uniqueValues" as a function that I use in one other sub routine in the module. The Code:
Private Function uniqueValues(InputRange As Range)
Dim cell As Range
Dim tempList As Variant: tempList = ""
Dim TFS As String
Set Eingaben = ThisWorkbook.Worksheets("Eingaben")
Set MainWs = ActiveWorkbook.Worksheets(Eingaben.Cells(3, 3).Value)
LastRow = MainWs.Range((Eingaben.Cells(4, 3).Value) & Rows.Count).End(xlUp).Row
TFS = Eingaben.Cells(12, 3).Value
Set InputRange = MainWs.Range(TFS & "2:" & TFS & LastRow)
For Each cell In InputRange
cell.Value = Replace(cell.Value, "/", "-")
cell.Value = Replace(cell.Value, "\", "-")
cell.Value = Replace(cell.Value, "?", "")
cell.Value = Replace(cell.Value, "*", "")
cell.Value = Replace(cell.Value, "[", "-")
cell.Value = Replace(cell.Value, "]", "")
If cell.Value <> "" Then
If InStr(1, tempList, cell.Value) = 0 Then
If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
End If
End If
Next cell
uniqueValues = Split(tempList, "|")
End Function
However, I have noticed that when I have other workbooks open (not active?), my whole sub routine stops working and when debugging its always stuck in this private function. I assume its applying this function to the other workbooks. I have thought of using a friend procedure or putting the sub and this function into a seperate module, but I dont think that would solve the issue. Any ideas?
Related
I have a macro that, from one worksheet, copies and seperates data, depending on their value in a certain column, into multiple worksheets based on an autofilter. After doing so, I format all sheets into a table. But because there are also other worksheets (always with the names "Such..." and "Tabelle...") in these workbooks, I want to exclude these when doing my worksheet loop. Here is the VBA:
Sub TechfelderBlätter()
Dim i As Integer
Set Eingaben = ThisWorkbook.Worksheets("Eingaben")
Set MainWS = ActiveWorkbook.Worksheets(Eingaben.Cells(3, 3).Value)
LastRow = MainWS.Range((Eingaben.Cells(4, 3).Value) & Rows.Count).End(xlUp).Row
TFS = Eingaben.Cells(12, 3).Value
myarray = uniqueValues(MainWS.Range(TFS & "2:" & TFS & LastRow))
For i = LBound(myarray) To UBound(myarray)
TFname = Left(myarray(i), 30)
Sheets.Add.Name = TFname
MainWS.Range("A1:" & TFS & LastRow).AutoFilter Field:=16, Criteria1:=myarray(i)
MainWS.Range("A1:" & TFS & LastRow).Cells.Copy _
Sheets(Left(myarray(i), 30)).Range("A1")
MainWS.Range("A1:" & TFS & LastRow).AutoFilter
Sheets(TFname).Range("A1").CurrentRegion.Select
Sheets(TFname).ListObjects.Add.Name = TFname & "_Table"
Sheets(TFname).ListObjects(TFname & "_Table").TableStyle = "TableStyleLight11"
Next i
MainWS.Activate
MainWS.Range("A1").CurrentRegion.Select
MainWS.ListObjects.Add.Name = MainWS.Name & "_Table"
MainWS.ListObjects(MainWS.Name & "_Table").TableStyle = "TableStyleLight11"
End Sub
Private Function uniqueValues(InputRange As Range)
Dim cell As Range
Dim tempList As Variant: tempList = ""
For Each cell In InputRange
cell.Value = Replace(cell.Value, "/", " ")
cell.Value = Replace(cell.Value, "\", " ")
cell.Value = Replace(cell.Value, "?", " ")
cell.Value = Replace(cell.Value, "*", " ")
cell.Value = Replace(cell.Value, "[", " ")
cell.Value = Replace(cell.Value, "]", " ")
If cell.Value <> "" Then
If InStr(1, tempList, cell.Value) = 0 Then
If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
End If
End If
Next cell
uniqueValues = Split(tempList, "|")
End Function
Problem1: The cell formatting, specifically the column width, does not get copied, resulting in most columns in the new worksheets being too narrow.
I would appreciate some help. Thanks in advance!
P.S.: I apologise if its a messy code, I know using activate and select isn´t good, but I didn´t know how else to code it.
Edit: I have solved one of the problems. The problem was: The Autofilter command is not dynamic because of the "Field:=16". Ideally, I would like to replace "16" with the TFS variable, in which the column letter is typed in by hand, in this case "P".
This is the solution I came up with by myself now. Instead of:
MainWS.Range("A1:" & TFS & LastRow).Cells.Copy _
Sheets(Left(myarray(i), 30)).Range("A1")
I now use this:
TFname = Left(myarray(i), 30)
MainWs.Range("A1:" & TFS & LastRow).Cells.Copy
With Sheets(TFname).Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
I have a IF-Statement, and I need to loop it throug column F.
This loop checks for the word "empty" in column F and if found, it gets entered into columns G too. In column H the current date gets added, if it was not already in it. If F and G have "empty" in it, and H a date, the If-Statement gets ended.
If Range("F2").Value = "empty" And Range("G2").Value = "" Then
Range("G2").Value = "empty"
ElseIf (Range("F2").Value = "empty" And Range("G2").Value = "empty") And Range("H2").Value = "" Then
Range("H2") = Date
ElseIf (Range("F2").Value = "empty" And Range("G2").Value = "empty") And Range("H2").Value <> "" Then
End If
Can someone help me to add this into a loop, that goes trough the lines?
It manly needs to go trough line 2 to 1500.
Any help would be apprechiated.
Kind regards.
Nested Statements in a Loop
Sub NestedStatements()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range("F2:H1500")
Dim rrg As Range
For Each rrg In rg.Rows
If CStr(rrg.Cells(1).Value) = "empty" Then
Select Case CStr(rrg.Cells(2).Value)
Case ""
rrg.Cells(2).Value = "empty"
Case "empty"
If CStr(rrg.Cells(3).Value) = "" Then
rrg.Cells(3).Value = Date
End If
End Select
End If
Next rrg
End Sub
Try something like this
Dim i as long
For i = 2 to 1500
If Range("F" & i).Value = "empty" And Range("G" & i).Value = "" Then
Range("G" & i).Value = "empty"
ElseIf (Range("F" & i).Value = "empty" And Range("G" & i).Value = "empty") And Range("H" & i).Value = "" Then
Range("H" & i) = Date
ElseIf (Range("F" & i).Value = "empty" And Range("G" & i).Value = "empty") And Range("H" & i).Value <> "" Then
'do something
End If
Next i
I would create a single sub to do the job - to which you pass the range that should be checked:
Option Explicit
Private Const colF As Long = 6
Private Const colG As Long = 7
Private Const colH As Long = 8
'-->> this is an example of how to call the sub
Sub test_checkColumnsFtoH()
checkColumnsFtoH ThisWorkbook.Worksheets("Table1").Range("A1:I500")
End Sub
'-->> this is your new sub
Sub checkColumnsFtoH(rgToBeChecked As Range)
Dim i As Long
With rgToBeChecked
For i = 2 To .Rows.Count
If .Cells(i, colF).Value = "empty" And .Cells(i, colG).Value = "" Then
.Cells(i, colG).Value = "empty"
ElseIf (.Cells(i, colF).Value = "empty" And .Cells(i, colG).Value = "empty") _
And .Cells(i, colH).Value = "" Then
.Cells(i, colH) = Date
End If
Next
End With
End Sub
I am using the cells property to avoid string concatination ("H" & i)
you don't need the last elseif - as nothing happens there.
I have a complicated split I need to do in VBA excel. I want to split each piece that starts "C:", includes "OCAK" and ends ".JPG" in range("C1") into A1,A2,A3... when click the button.
FROM THIS
TO THIS
I'm still doing research and testing, but I can't find a real viable solution. Any ideas would be greatly appreciated.
Private Sub buton_Click()
If Cells(1, "c").Text Like "C:*OCAK*.jpg*" Then
Dim jpgStart As Long
jpgStart = InStr(Cells(1, "c").Text, ".jpg")
Dim result As String
result = Left(Cells(1, "c").Text, jpgStart - 1)
Cells(1, "c").Offset(0, -2).Value = result
Else
Cells(1, "c").Offset(0, -2).Value = vbNullString
End If
End Sub
The problem is in the splitting actually. In the input, the new line should be used as a delimiter as well. Thus, consider changing the input a bit to something like this:
readCell = Worksheets(1).Cells(1, "C")
readCell = Replace(readCell, Chr(13) & Chr(10), " ")
readCell = Replace(readCell, vbCrLf, " ")
readCell = Replace(readCell, vbNewLine, " ")
readCell = Replace(readCell, vbLf, " ")
Once the input is fixed an array can be built of the units - myArray = Split(readCell). Looping through the array and using Like "C:*OCAK*.jpg" works quite well:
Public Sub TestMe()
Dim readCell As String
readCell = Worksheets(1).Cells(1, "C")
readCell = Replace(readCell, Chr(13) & Chr(10), " ")
readCell = Replace(readCell, vbCrLf, " ")
readCell = Replace(readCell, vbNewLine, " ")
readCell = Replace(readCell, vbLf, " ")
Dim myArray As Variant
myArray = Split(readCell)
Dim myVar As Variant
Dim currentRow As Long: currentRow = 1
For Each myVar In myArray
If myVar Like "C:*OCAK*.jpg" Then
Worksheets(1).Cells(currentRow, "A") = myVar
currentRow = currentRow + 1
End If
Next
End Sub
In your button macro code loop the cells in column c; I have to assume you know how to set that up and do it. Then for each cell in that range:
with thisworkbook.worksheets("theNameOfYourSheet")
dim loopRange As Range
set loopRange=.Range(.Cells(1,3),.Cells(.UsedRange.Rows.Count,3))
end with
dim cell as Range
for each cell in loopRange
If cell.text Like "C:*.jpg*" Then
Dim jpgStart As Long
jpgStart = Instr(cell.text,".jpg")
Dim result As String
result= Left(cell.text,jpgStart-1)
cell.offset(0,-1).Value=result
Else
cell.offset(0,-1).Value = vbNullString
End If
Next
Split by vbLf
Split by a blank space character
Test against your result
Code:
Option Explicit
Sub GetOcak()
Dim arr As Variant
arr = Split(Cells(1, 3).Value, vbLf)
Dim i As Long
Dim j As Long
j = 1
For i = 0 To UBound(arr)
If Left(Split(arr(i), " ")(0), 7) = "C:\OCAK" And _
Right(Split(arr(i), " ")(0), 4) = ".jpg" Then
Cells(j, 1).Value = Split(arr(i), " ")(0)
j = j + 1
End If
Next i
End Sub
check for range of cells[say C1:E5], if cell contains a value find its row [say row-4] append a cell [say B6] with cell's data and its corresponding rows data.
Sub Demo()
Dim str As String
str = ""
For Each cel In Range("C1:E5")
If Not IsEmpty(cel) Then
If str = "" Then
str = Range("B" & cel.Row) & "=" & cel.Value
Else
str = str & ", " & Range("B" & cel.Row) & "=" & cel.Value
End If
End If
Next
If str <> "" Then Range("B6") = str
End Sub
Sub test()
Dim rng As Range
Dim tmp As String
Set rng = Range("C1:E5")
For Each cell In rng
If cell.Value <> "" Then
tmp = tmp + " " + Cells(cell.Row, 2).Value + " = " + cell.Value
End If
Next cell
Range("B6").Value = tmp
End Sub
I'm in the process of looping through an Excel spreadsheet and combining all the cells into a string, which I did. Now I need to format the string with XML tags before I send it for upload, and I'm having some difficulty working the tagging into the loop correctly. It seems like it is almost working, but a few of the tags are not going in the correct place. Any help would be much appreciated.
Code:
Public file As String
Sub locate_file()
Dim sheet1_95 As String
Dim theRange As Range
Dim strVal As String
Dim wb As Workbook
Dim counterDT As Integer
Dim counterSVR As Integer
Dim counterMB As Integer
Dim outputStr As String
'prompt user for location of other excel sheet'
file = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
Set wb = Workbooks.Open(file)
Dim cell As Range
'initializing the xml string'
strVal = "<root>"
Sheets("DT").Activate
counterDT = 1
For Each cell In ActiveSheet.UsedRange.Cells
'this first if-block is just excluding the few header cells from the data collection'
If cell.Value <> "SKU" And cell.Value <> "P Number" And cell.Value <> "Month" _
And cell.Value <> "DP Dmd" And cell.Value <> "Vertical" Then
If cell.Column = "1" Then
strVal = strVal & "<item><sku>" & cell.Value & "</sku>"
ElseIf cell.Column = "2" Then strVal = strVal & "<pnum>" & cell.Value & "</pnum>"
ElseIf cell.Column = "3" Then strVal = strVal & "<month>" & cell.Value & "</month>"
ElseIf cell.Column = "4" Then strVal = strVal & "<forecast>" & cell.Value & "</forecast>"
Else: strVal = strVal & "<vertical>" & cell.Value & "</vertical>"
End If
counterDT = counterDT + 1
If cell.Row <> 1 Then
If counterDT Mod 6 = 0 Then
strVal = "<item>" & strVal & "<percent>" & category.percent(cell, "DT") & "</percent>"
Else: End If
Else: End If
End If
Next
strVal = strVal & "</root>"
So basically the problem is, this loop/nested if is printing like 30 "item" tags at the very beginning of the string and I'm not sure why.
For some other information, the Excel sheet is 6 columns, and will always be 6.
When I'm creating xml tags, I like to move the actual tagging into a separate function. The upside is that it ensures my tags match. The downside is that you don't "apply" the tags until the end. Tags like item and root are done after all the tags within them are done. Here's an example:
Sub locate_file()
Dim sVal As String
Dim sRow As String
Dim wb As Workbook
Dim sh As Worksheet
Dim lCntDT As Long
Dim rCell As Range
Dim rRow As Range
Dim vaTags As Variant
gsFile = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If gsFile <> "False" Then
Set wb = Workbooks.Open(gsFile)
Set sh = wb.Sheets("DT")
vaTags = Array("sku", "pnum", "month", "forecast", "vertical")
lCntDT = 1
For Each rRow In sh.UsedRange.EntireRow
sRow = ""
If rRow.Cells(1) <> "SKU" Then
For Each rCell In Intersect(sh.UsedRange, rRow).Cells
If rCell.Column <= 4 Then
sRow = sRow & TagValue(rCell.Value, vaTags(rCell.Column - 1))
Else
sRow = sRow & TagValue(rCell.Value, vaTags(UBound(vaTags)))
End If
Next rCell
lCntDT = lCntDT + 1
If rRow.Row <> 1 And lCntDT Mod 6 = 0 Then
sVal = sVal & TagValue("CatPct", "percent")
End If
sRow = TagValue(sRow, "item")
sVal = sVal & sRow & vbNewLine
End If
Next rRow
sVal = TagValue(sVal, "root")
End If
Debug.Print sVal
End Sub
Function TagValue(ByVal sValue As String, ByVal sTag As String) As String
TagValue = "<" & sTag & ">" & sValue & "</" & sTag & ">"
End Function