WorksheetFunction.CountA() is returning 0 when i dont think it should be - excel

Basically i need to get a list of each different type of issue from the first sheet and then display on the second.
The first sheet has 1 row which is just titles for the columns and then 4 rows with data.
It was wokring but I think i accidently changed something i cant work out whats wrong now, if someone can see an issue or if theres a better way of doing this then im all ears.
Sub ListQueryTypes()
'Create Variables'
Dim numberOfIssues As Integer
Dim numberOfMacroIssues As Integer
Dim numberOfReportIssues As Integer
Dim numberOfTechnicalIssues As Integer
Dim numberOfTrendIssues As Integer
Dim cellValue As String
'Set query register as active worksheet'
Sheets("Query Register").Activate
'set range for search'
Set myRange = Range("G:G")
'Minus 1 for the first row being column name'
numberOfIssues = Application.WorksheetFunction.CountA(myRange)
'Do, for as many issues as were found previously'
For i = 2 To numberOfIssues + 1
cellValue = ActiveSheet.Cells(i, 7).Value
Select Case cellValue
Case "Macro"
numberOfMacroIssues = numberOfMacroIssues + 1
Case "Report"
numberOfReportIssues = numberOfReportIssues + 1
Case "Technical"
numberOfTechnicalIssues = numberOfTechnicalIssues + 1
Case "Trend"
numberOfTrendIssues = numberOfTrendIssues + 1
End Select
Next i
Sheets("Inventory").Activate
ActiveCell = Cells(2, 2)
ActiveCell.Value = numberOfMacroIssues
ActiveCell.Offset(1).Value = numberOfReportIssues
ActiveCell.Offset(2).Value = numberOfTechnicalIssues
ActiveCell.Offset(3).Value = numberOfTrendIssues

To collect all the issues mentioned in the comments, to improve your code. Have a look at the comments in the code
Option Explicit 'force to declare all variables correctly (this way you don't forget any)
Public Sub ListQueryTypes()
'Create Variables'
Dim numberOfIssues As Long 'was Integer but we can always use Long (only advantages) and Excel has more rows than Integer can handle
Dim numberOfMacroIssues As Long
Dim numberOfReportIssues As Long
Dim numberOfTechnicalIssues As Long
Dim numberOfTrendIssues As Long
'Dim cellValue As String 'you don't need that variable see below
'Set query register as active worksheet'
'Sheets("Query Register").Activate 'instead of activate we define that sheet as variable which is more save
'and we use Worksheets
Dim WsQueryReg As Worksheet
Set WsQueryReg = ThisWorkbook.Worksheets("Query Register")
'set range for search'
Dim myRange As Range 'we should to declare all variable properly
Set myRange = WsQueryReg.Range("G:G") 'we need to define in which sheet the range is
'Minus 1 for the first row being column name'
numberOfIssues = Application.WorksheetFunction.CountA(myRange)
'Do, for as many issues as were found previously'
Dim i As Long 'declare every variable first
For i = 2 To numberOfIssues + 1
'cellValue = WsQueryReg.Cells(i, 7).Value 'no need to write this in a variable we can use it directly in Select Case
Select Case WsQueryReg.Cells(i, 7).Value 'was cellValue before
Case "Macro"
numberOfMacroIssues = numberOfMacroIssues + 1
Case "Report"
numberOfReportIssues = numberOfReportIssues + 1
Case "Technical"
numberOfTechnicalIssues = numberOfTechnicalIssues + 1
Case "Trend"
numberOfTrendIssues = numberOfTrendIssues + 1
End Select
Next i
'we can use with instead of activating a sheet and selecting a cell
'this also specifies in which sheet and workbook the cell is
With ThisWorkbook.Worksheets("Inventory").Cells(2, 2)
.Value = numberOfMacroIssues
.Offset(1).Value = numberOfReportIssues
.Offset(2).Value = numberOfTechnicalIssues
.Offset(3).Value = numberOfTrendIssues
End With
End Sub
Instead of looping through your rows For i = 2 To numberOfIssues + 1 you could probably count Macro, Report, etc. like
With WsQueryReg
numberOfMacroIssues = Application.WorksheetFunction.CounfIf(.Range(.Cells(2, 7), .Cells(numberOfIssues + 1, 7)), "Macro")
numberOfReportIssues = Application.WorksheetFunction.CounfIf(.Range(.Cells(2, 7), .Cells(numberOfIssues + 1, 7)), "Report")
'… others here
End With

Related

Best way to copy data to a new sheet and reorganize it (VBA)

I'm writing a VBA program which copies and organizes data from one master sheet into numerous other sheets. One of the recipient sheets unifies all the data from the master sheet which holds the same id number into a single row. For this operation, I am looping through the master sheet for each id number, copying each row which holds the current id number into a new sheet purely used for calculations and organizing, and rearranging the data in this sheet into the new row. The resultant row is copied into the recipient sheet. This process of organizing data for every id number takes a long time to process, especially given the very large size of this sheet and the processing time of the other recipient sheets. I'm wondering if there is a better way to organize and copy data without using an intermediate calculation sheet.
The below code is the main sub, which calls another sub OrganizeAndCopyToPal, which organizes the data in the calculation sheet and copies the result into the recipient sheet.
Sub PalletAssemblyLog()
Dim allidNum As Range
Dim curridNum As Range
Dim rowCount As Long
Dim idNum
Dim I As Long
Dim j As Long
Dim machineLoc As String
Dim calc As Worksheet
Dim full As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set full = Sheet4
Set pal = Sheet1
For I = 2 To rowCount
For j = 2 To rowCount
If full.Cells(j, 17).Value = idNum Then
If allidNum Is Nothing Then
Set allidNum = full.Cells(j, 17)
Else
Set allidNum = Union(allidNum, full.Cells(j, 17))
End If
End If
Next j
Set curridNum = allidNum.EntireRow
calc.Activate
calc.Cells.Clear
full.Activate
curridNum.Copy calc.Range("A1")
OrganizeAndCopyToPal curridNum
Next I
End Sub
The below sub organizes and copies the data for each id number. The final sub to copy the data isn't related to the matter of simplifying this task so I'm not including it.
Sub OrganizeAndCopyToPal(curridNum)
Dim calc As Worksheet
Dim pal As Worksheet
Set calc = Sheet3
Set pal = Sheet1
calc.Activate
Dim rowCount As Long
rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim palRow As Long
palRow = rowCount + 2
Dim partRow As Long
partRow = palRow + 2
Dim currPartCount As Range
Dim assembly As String
Dim id As String
Dim location As String
Dim machType As String
Dim machLoc As String
Dim currPart As String
Dim link As String
Dim tot As Long
tot = 0
With calc
.Cells(1, 1).Copy .Cells(palRow, 2)
assembly = .Cells(1, 1).Value
.Cells(1, 2).Copy .Cells(palRow, 5)
id = .Cells(1, 17).Value
asArray = SplitMultiDelims(id, "|-")
'MsgBox asArray(0) & " " & asArray(1) & " " & asArray(2)
machArray = Split(.Cells(1, 8), "-")
machType = machArray(0)
.Cells(palRow, 3) = machType
machLoc = .Cells(1, 8).Value
.Cells(palRow, 4) = machLoc
.Cells(1, 17).Copy .Cells(palRow, 10)
location = Cells(1, 9)
.Cells(palRow, 1) = location
For I = 1 To rowCount
partArray = Split(.Cells(I, 16).Value, ",")
For j = 0 To UBound(partArray)
partArray2 = Split(partArray(0), "-")
partPrefix = partArray2(0)
If j = 0 Then
currPart = partArray(j)
Else
currPart = partPrefix & "-" & CStr(partArray(j))
End If
tf = 1
For k = 0 To tot
If Cells(partRow + k, 1).Value = currPart Then
tf = 0
Exit For
End If
Next k
If tf = 1 Then
.Cells(partRow + tot, 1).Value = currPart
tot = tot + 1
End If
Next j
Next I
For I = 1 To tot
Cells(palRow, 10 + I).Value = Cells(partRow + I - 1, 1)
Next I
End With
CopyToPal curridNum, palRow
End Sub
Thank you for any tips or help that you can offer.
Before getting into more exotic solutions - the easiest thing you can do is set
Application.Calculation = xlCalculationManual
Before getting stuck into much code.
Then when you need to do an update before copying any data that may change due to formulae calcs, run
Application.Calculate
and eventually at the end reset it to
Application.Calculation = xlCalculationAutomatic
You can disable screen updates too, but the above will be the big (easy) one. After that we're into copying to arrays and working in them then pasting back.

Object variable or with block variable not set error for creating worksheets

The code below works fine on its own but once i add option explicit at the start, the object variable or with block variable not set error appears at the sheetname = index3. I have seen other threads where the issue is solved by set sheetname = ThisWorkbook.Worksheets("") but there are 3 sheets that will be created before i used this statement so i don't think it can work that way. Any ideas to solve this?
Option explicit
Private Sub createvramp()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As Worksheet
Dim indexrowcount As Integer
j = 2
iRow = 1
lastline = ActiveSheet.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 99 ' Max Group Size with Same name in F to H column
count = 1
If Cells(iRow, "H").Value = "Vramp_M1" Then
sheetname = "Index1"
ElseIf Cells(iRow, "H").Value = "Vramp_M2" Then
sheetname = "Index2"
Else
sheetname = "Index3" '<-------error occurs here
End If
For aRow = a To b
If Cells(iRow, "H") = Cells(aRow, "H") And Cells(iRow, "I") = Cells(aRow, "I") And Cells(iRow, "J") = Cells(aRow, "J") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":AP" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count + 1
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
If you just want to set the sheet name in your code, use Dim sheetname As String. Option Explicit helps a lot, but you must be very careful when you declare variables...
It happened that the error to appear on that row only because the first two conditions were False...
It is also good to avoid using of ActiveSheet, Sheets(...), Range("A" ...), Cells(aRow,...).
Everything expressed in this way refers to ActiveSheet. When you will work on a different sheet, maybe on a different workbook and you need to process a specific sheet (Sheets(sheetname).Range...), you may face a big mess. Try to define the sheet with reference to its workbook. Each range to reference the sheet where it belongs...
At least Dim Sh as Worksheet followed by Set Sh = ActiveSheet (use your working sheet). And then use Sh.Range("A...), Sh.Cells(aRow,...) and so on...
It is recommended to cultivate good habits which will help you in the future...

Transposing Sets of Columns on Top of Each Other in Excel

So I have multiple sets of 3 columns. Each set is always in the same column order ("SKU", "Sales". "Date".)
I am wondering is there is a VBA script or other method that would do the following:
1.) Copy G:I
2.) Paste into A:C
3.) Copy J:L
4.) Paste into A:C (Underneath G:I's data)
5.) Copy M:O
6.) Paste into A:C (underneath J:L's data)
7.) Repeat (I would like it to repeat every 3 columns forever, but if that's not possible I'll manually input the columns if I have
to.)
This is a visual of what I'm looking for: http://i.imgur.com/AagLIm8.png
I also uploaded the workbook in case you need it for reference: https://www.dropbox.com/s/wea2nr4xbfo4934/Workbook.xlsx?dl=0
Thanks for the help!
The code below does what you want, and I've included some ".select" lines to help you understand. I suggest you step through it to become clear, as in the animated gif. Then, remove all the ".select" lines of code.
Option Explicit
Sub moveData()
Dim rSource As Range, rDest As Range, r As Range
Dim tbl As Range, rowNum As Integer
Const colNum = 3
Set rDest = Range("A1")
Set rSource = Range("G1")
Set r = rSource
While r <> ""
Set r = Range(r, r.End(xlDown))
Set tbl = Range(r, r.Offset(0, colNum - 1))
tbl.Select
Set tbl = Range(tbl, tbl.End(xlDown).Offset(1, 0))
tbl.Select
tbl.Copy
rDest.Select
rDest.PasteSpecial (xlPasteAll)
Set rDest = rDest.Offset(tbl.Rows.Count, 0)
Set r = r(1, 1)
r.Select
Set r = r.Offset(0, colNum)
r.Select
Wend
End Sub
try to do this:
Sub CopyColumns()
Dim actualRow As Integer
Dim actualColumn As Integer
Dim rowFrom As Integer
Dim myColumns As Integer
Dim startColumn As Integer
myColumns = 3 'the number of columns before start repeating (in your case is SKU, Sales, Date, so there are 3 columns)
startColumn = 7 'the column where start de data. In your example is the Column G
actualRow = 1
actualColumn = 1
rowFrom = 1
Dim eoRows As Boolean
eoRows = False
While eoRows = False
'verify if there's no more data
If Cells(rowFrom, startColumn) = "" Then
eoRows = True
Else
'verify if there's no more row
While Cells(rowFrom, startColumn) <> ""
For i = startColumn To startColumn + myColumns - 1
Cells(actualRow, actualColumn) = Cells(rowFrom, i)
actualColumn = actualColumn + 1
Next
rowFrom = rowFrom + 1
actualRow = actualRow + 1
actualColumn = 1
Wend
rowFrom = 1
startColumn = startColumn + myColumns
End If
Wend
End Sub

Excel 2013 Overflow due to lack of VBA optimization

I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True

Trying to create a specific loop in excel to get an output

bear with me on this question. I'm pretty sure it'll be easy for those who have knowledge in this field, but I do not know much about VBA or how to create loops in Excel to be creating this formula:
Please review the picture here
What I'm trying to construct is a loop that'll concatenate those numbers.
EX. I want to concatenate in this order A2,"-",B2; A3,"-",B2; A4,"-",B2.....A16,"-",B2
Once everything in A1- A16 is concatenated with B2, I want to move on to concatenating A1-A16 with B3.EX: A2,"-",B3; A3,"-",B3.....A16,"-",B3
I know this is possible because certain loops can be created to go through with this procedure, but I do not know VBA and am not sure if this is possible with just the pre-existing formulas in Excel. Thanks to anyone who helps.
From what you described, it's pretty simple nested loop. Below code will concatenate the way you wanted and store it to column C.
Sub MyConcat()
Const lColA As Long = 1
Const lColB As Long = 2
Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sTxt As String
Dim lRowA As Long, lRowB As Long, lRowTxt As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowA = 1
lRowTxt = 1
oWS.Columns(lColTxt).Clear ' remove previous data on Column C
Do Until IsEmpty(oWS.Cells(lRowA, lColA))
sTxt = ""
lRowB = 2
Do Until IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Loop
Set oWS = Nothing
End Sub
EDIT: This should fit in many situations of number of Parent SKUs.
Usable on your data in second image, including another set of "TuTi" and Parent SKUs of different length. Please try understand it, it will be a whole page of explanations.
Private Const lColA As Long = 1
Private Const lColB As Long = 2
Private Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sGroup As String, lRowCurr As Long, lRowTxt As Long
Sub MyConcat()
Dim oRng As Range, lStopRow As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowCurr = 1 ' Current Row index
lRowTxt = 1 ' Results from Row 1
sGroup = ""
With oWS
.Columns(lColTxt).Clear ' remove previous data on Column C
' Row of LastCell in current sheet + 1
lStopRow = .Cells.SpecialCells(xlLastCell).Row + 1
' Row of "Ctrl-Up" from LastCell Row at column A
lStopRow = .Cells(lStopRow, lColA).End(xlUp).Row + 1
' Start processing rows until until StopRow in column A
Do Until lRowCurr = lStopRow
Set oRng = .Cells(lRowCurr, lColA)
If IsGroupCell(oRng) Then
sGroup = oRng.Value ' Stores Group text
ElseIf IsParentSKU(oRng) Then
Call MyConcat2 ' Invoke the mix sub that writes the result in column C
End If
lRowCurr = lRowCurr + 1
Set oRng = Nothing
Loop
End With
Set oWS = Nothing
End Sub
Private Sub MyConcat2()
Dim sTxt As String, oRng As Range
Dim lRowA As Long, lRowB As Long
lRowA = lRowCurr + 1
Set oRng = oWS.Cells(lRowA, lColA)
' Stop mixing the values when it is a Group or Parent SKU row
Do Until IsGroupCell(oRng) Or IsParentSKU(oRng) Or IsEmpty(oRng)
sTxt = ""
lRowB = lRowCurr + 1
' Don't mix if it is a Parent SKU
Do Until IsParentSKU(oWS.Cells(lRowB, lColA)) Or IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sGroup & "-" & sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Set oRng = oWS.Cells(lRowA, lColA)
Loop
lRowCurr = lRowA - 1
Set oRng = Nothing
End Sub
Private Function IsGroupCell(oRng As Range) As Boolean
IsGroupCell = (Not IsNumeric(Left(oRng.Value, 1)) And IsEmpty(oRng.Offset(0, 1)))
End Function
Private Function IsParentSKU(oRng As Range) As Boolean
IsParentSKU = (IsNumeric(oRng.Value) And IsNumeric(oRng.Offset(0, 1).Value))
End Function

Resources