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...
Related
I have written this code to eliminate columns based on header names. On one workbook I have the list of headers to delete, and on the other workbook I have the columns themselves.
'setup
Dim nominas_ws As Worksheet
Set nominas_ws = ActiveSheet
Dim conceptos_wb As Workbook
Set conceptos_wb = Workbooks.Open("C:\Users\deepw\Desktop\nominas\conceptos.xlsx")
Dim conceptos_ws As Worksheet
Set conceptos_ws = conceptos_wb.Worksheets(1)
Dim nominas_last_row, nominas_last_column, conceptos_last_row, conceptos_last_column As Long
nominas_last_row = nominas_ws.Cells(Rows.Count, 5).End(xlUp).Row
nominas_last_column = nominas_ws.Cells(1, Columns.Count).End(xlToLeft).Column
conceptos_last_row = conceptos_ws.Cells(Rows.Count, 5).End(xlUp).Row
conceptos_last_column = conceptos_ws.Cells(1, Columns.Count).End(xlToLeft).Column
'delete names & unwanted columns
nominas_ws.Range("C2:C" & nominas_last_row).ClearContents
Dim conceptos_headers As Range
Dim i, c As Integer
Dim concepto_input As String
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = 1 To nominas_last_column
If Cells(c, 1).Value = "concepto_input" Then Cells(c, 1).EntireColumn.delete
Next c
Next i
Thank you in advance for your help.
If Cells(c, 1).Value = "concepto_input" Then
you are checking for the string literal "concepto_input", not the value in the variable concepto_input. Should be:
If Cells(c, 1).Value = concepto_input Then
If there might be multiple matches for any given column heading, you should loop backwards:
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = nominas_last_column To 1 Step -1
If conceptos_ws.Cells(c, 1).Value = concepto_input Then
conceptos_ws.Columns(c).Delete
'Exit For 'if there can only be one match per search term
End If
Next c
Next i
Note it's also good practise to never use Range/Cells without an explicit worksheet qualifier.
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.
Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
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 String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?
Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
I am having an issue getting array values to compare to values stored in cells on the spreadsheet.
I have tried having the cell value compare directly to the array value, but the check fails every time.
To attempt to correct this issue I have tried assigning the cell value on each iteration to a variable dimmed as varient (Just as the array is dimmed a varient)
Values are added to the array successfully and the varient type is used as some invoices are numbers only while others include letters.
When I walk through my code the variable is not being assigned/accepting a value. Every time the comparison statement is reached the variable shows that it is empty.
Dim Paidlrow As Long
Dim lrow As Long
Dim wb As Workbook
Dim Consolid As Worksheet
Dim PaidInv As Worksheet
Dim Summary As Worksheet
Dim Invoices() As Variant
Dim InvCheck As Variant
Dim txt As String
Dim Formula As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim Cleared As Long
Dim LInv As Long
Dim NewBlank As Long
Dim MaxSheets As Integer
Set wb = Workbooks("Wire Payments projections for Euro's")
Set Consolid = wb.Sheets("Consolidation")
Set Summary = wb.Sheets("Pay Summary")
Set PaidInv = wb.Sheets("Paid Invoices")
'define define and define
MaxSheets = wb.Sheets.Count
lrow = Consolid.Cells(Rows.Count, 1).End(xlUp).Row + 1
Cleared = 1
ReDim Preserve Invoices(1 To Cleared)
i = 2
With wb
'begin inv extraction loop
For i = 2 To lrow
ReDim Preserve Invoices(1 To Cleared)
'if inv is marked for payment, add to array and move details to paid inv tab
With PaidInv
Paidlrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
With Consolid
If .Cells(i, 10) = "X" Or .Cells(i, 10) = "x" Then
Invoices(Cleared) = .Cells(i, 1)
Consolid.Rows(i).Copy Destination:=PaidInv.Cells(Paidlrow, 1)
Consolid.Rows(i).Clear
Cleared = Cleared + 1
End If
End With
Next i
End With
'loop through each sheet to remove paid invoices identifie in previous loop
For k = 1 To MaxSheets
If wb.Sheets(k).Name <> Summary.Name And wb.Sheets(k).Name <> PaidInv.Name And wb.Sheets(k).Name <> Consolid.Name Then
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
For j = LBound(Invoices) To UBound(Invoices)
For l = 7 To LInv
InvCheck = .Cells(l, 2).Value
If Invoices(j) = InvCheck And InvCheck <> "" Then
'.Rows(l).Delete
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A7:K7").Copy
.Range(.Cells(NewBlank, 1), .Cells(NewBlank, 11)).PasteSpecial Paste:=xlPasteFormats
'.Cells(NewBlank, 1) = Right(.Cells(1, 9), 6)
'Formula = "=$B$3*I"
'Formula = Formula & NewBlank
'.Cells(NewBlank, 10).Formula = Formula
End If
Next l
Next j
End With
End If
Next k
I have commented out code for the ease of testing. With the way it is now it should format some additional cells to match the formatting above it.
UPDATE
For kicks and giggles, I changed the Array and associated variable check to String type rather than variant. For some reason, this fixed the issue I was having. I am so confused...
There seems to be a dot missing:
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
should be:
With wb.Sheets(k)
LInv = .Cells(Rows.Count, 2).End(xlUp).Row + 1
to ensure that LInv is read from sheet number k.
As it is, the code is equivalent to:
With wb.Sheets(k)
LInv = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
and, if the active sheet doesn't have any values in the cells you are looking at, the comparison will fail.
There's a similar issue with this line later on in the code:
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
should be:
NewBlank = .Cells(Rows.Count, 1).End(xlUp).Row + 1
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