I have a workbook with several worksheets. The main worksheet is the Data worksheet.
The search criteria are in the Data worksheet B2,C2 and D2.The other sheets are cross tabs in which the prices are located. The prices I am looking for should be transferred in sheet Data column G2. I stuck with following code.
Dim wks As Worksheet
Dim wksData As Worksheet: Set wksData = Sheets("Data")
Dim lngrow As Long
Dim lngrow2 As Long
Dim lngSpalte As Long
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
Select Case wksData.Cells(lngrow, 2).Value
Case "Standard"
Set wks = Sheets("Standard")
Case "Express Plus"
Set wks = Sheets("Express Plus")
Case "Express Saver"
Set wks = Sheets("Express Saver")
End Select
For lngrow2 = 2 To wks.Cells(Rows.Count, 2).End(xlUp).Row
If Trim(wks.Cells(lngrow2, 2).Value) = Trim(wksData.Cells(lngrow, 3).Value) Then
For lngSpalte = 2 To 10
If Trim(wks.Cells(lngSpalte, 3).Value) = Trim(wksData.Cells(lngrow, 4)) Then
wksData.Cells(lngrow, 7).Value = wks.Cells(lngrow2, lngSpalte).Value
Exit For
End If
Next
End If
Next
Next
Is anyone able to help? Thank you!
EDIT - based on your sample workbook...
Sub Tester()
Dim wksData As Worksheet, wks As Worksheet
Dim lngrow As Long
Dim delType, delZone, delWeight, mCol, rv
Dim rngWts As Range, arrWts, rngZones As Range, i As Long, w As Double
Set wksData = Sheets("Data")
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
delType = Trim(wksData.Cells(lngrow, "B").Value) 'use some descriptive variables!
delZone = wksData.Cells(lngrow, "C").Value
delWeight = CDbl(Trim(wksData.Cells(lngrow, "D").Value))
rv = "" 'clear result value
Select Case delType
Case "Standard", "Express Plus", "Express Saver"
Set wks = Sheets(delType) 'simpler...
Set rngWts = wks.Range("A3:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row)
arrWts = rngWts.Value
'loop over the weights data
For i = 1 To UBound(arrWts, 1) - 1
If delWeight >= arrWts(i, 1) And delWeight < arrWts(i + 1, 1) Then
Set rngZones = wks.Range("B2", wks.Cells(2, Columns.Count).End(xlToLeft)) 'zones range
mCol = Application.Match(delZone, rngZones, 0) 'find the matching Zone
If Not IsError(mCol) Then 'got zone match?
rv = rngWts.Cells(i).Offset(0, mCol).Value
Else
rv = "Zone?"
End If
Exit For 'stop checking weights column
End If
Next i
If Len(rv) = 0 Then rv = "No weight match"
Case Else
rv = "Delivery type?"
End Select
wksData.Cells(lngrow, "G").Value = rv 'populate the result
Next
End Sub
Related
I have made this code to create an output sheet where columns from different sheets are sorted by header name and pasted one after the other.
For some reason, it is not pasting the columns underneath each other, but instead overwriting each one with the next:
Dim ws As worksheet
Dim max_ws As worksheet
Dim output_ws As worksheet
Dim max_ws_header As Range
Dim output_ws_header As Range
Dim header_cell As Range
Dim cc As Long
Dim max_cc As Long
Dim output_header_counter As Long
Dim ws_header_counter As Long
Dim output_header_name As String
Dim ws_header_name As String
Application.DisplayAlerts = False
Sheets("indice").Delete
Sheets("aneca").Delete
Application.DisplayAlerts = True
For Each ws In Worksheets
ws.Rows(1).EntireRow.Delete
ws.Columns.Hidden = False
Next ws
max_cc = 0
For Each ws In Worksheets
cc = last_column_index(ws, 1)
If cc > max_cc Then
max_cc = cc
Set max_ws = ws
End If
Next ws
Sheets.Add.Name = "Output"
Set output_ws = Sheets("Output")
Set max_ws_header = max_ws.Range(max_ws.Cells(1, 1), max_ws.Cells(1, max_cc))
Set output_ws_header = output_ws.Range(output_ws.Cells(1, 1), output_ws.Cells(1, max_cc))
max_ws_header.Copy output_ws_header
For Each ws In Worksheets
If ws.Name <> "Output" Then
For output_header_counter = 1 To max_cc
output_header_name = output_ws.Cells(1, output_header_counter).Value
For ws_header_counter = 1 To max_cc
ws_header_name = ws.Cells(1, ws_header_counter).Value
If ws_header_name = output_header_name Then
ws.Range(Cells(1, ws_header_counter), Cells(last_row_index(ws, ws_header_counter), ws_header_counter)).Copy _
output_ws.Range(Cells(last_row_index(output_ws, output_header_counter) + 1, output_header_counter), Cells(last_row_index(ws, ws_header_counter), output_header_counter))
End If
Next ws_header_counter
Next output_header_counter
End If
The functions last_row_index and last_column_index are UDFs that I made as follows:
Function last_row_index(target_worksheet As worksheet, target_column_index As Long) As Long
last_row_index = target_worksheet.Cells(Rows.Count, target_column_index).End(xlUp).Row
End Function
Function last_column_index(target_worksheet As worksheet, target_row_index As Long) As Long
last_column_index = target_worksheet.Cells(target_row_index, Columns.Count).End(xlToLeft).Column
End Function
Here is an example of the output:
I figured out the solution, posting it here to close the question:
For Each ws In Worksheets
If ws.Name <> "Output" And ws.Name <> "indice" And ws.Name <> "aneca" Then
For row_index = 2 To last_row_index(ws, 1)
output_counter = last_row_index(output_ws, 1)
For column_index = 1 To last_column_index(ws, 1)
ws_header = ws.Cells(1, column_index).Value
For o_column_index = 1 To max_cc
output_header = output_ws.Cells(1, o_column_index).Value
If output_header = ws_header Then
ws.Cells(row_index, column_index).Copy output_ws.Cells(output_counter + 1, column_index)
Exit For
End If
Next o_column_index
Next column_index
Next row_index
End If
Next ws
I made an output counter variable and made it find the last row each time it starts on a new row in the input sheets, and then I add +1 to it every time it pastes a row.
Screenshot#1
So i have to replace positive & negative numbers in column "A", from sheet "1" to sheet second[positive] and third sheet[negative].
Here is what i tried:
Sub Verify()
Dim row As Long
For row = 1 To 20
If ActiveSheet.Cells(row,1) <> "" Then
If ActiveSheet.Cells(row,1) > 0 Then
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
Here is what that program do:
Screenshot#2
So as we see i am getting positive values in column "B" sheet 1.
Your code is not currently working because you are only using ActiveSheet, rather than placing data on other worksheets as required. Below is some VBA code that loops column A in your original sheet, and outputs the data to column A in two different sheets as required:
Sub sSplitPositiveNegative()
Dim wsOriginal As Worksheet
Dim wsPositive As Worksheet
Dim wsNegative As Worksheet
Dim lngLastRow As Long
Dim lngPositiveRow As Long
Dim lngNegativeRow As Long
Dim lngLoop1 As Long
Set wsOriginal = ThisWorkbook.Worksheets("Original")
Set wsPositive = ThisWorkbook.Worksheets("Positive")
Set wsNegative = ThisWorkbook.Worksheets("Negative")
lngLastRow = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
lngNegativeRow = 2
lngPositiveRow = 2
For lngLoop1 = 1 To lngLastRow
If wsOriginal.Cells(lngLoop1, 1).Value > 0 Then
wsPositive.Cells(lngPositiveRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngPositiveRow = lngPositiveRow + 1
Else
wsNegative.Cells(lngNegativeRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngNegativeRow = lngNegativeRow + 1
End If
Next lngLoop1
Set wsPositive = Nothing
Set wsNegative = Nothing
Set wsOriginal = Nothing
End Sub
You will need to change the names of the worksheets referenced in the code to match those in your workbook.
Regards
Made the code a little reusable for you. Feel free to change sheet names or the last_row variable. The last_pos_val and last_neg_val are used so you won't have empty rows on the second and third sheet. You didn't specify what to do with zero, so it's currently added to the negative sheet.
Sub Verify()
Dim row As Long, last_row As Long, last_pos_val As Long, last_neg_val As Long
Dim ws_source As Worksheet, ws_pos As Worksheet, ws_neg As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws_source = wb.Sheets("Sheet1")
Set ws_pos = wb.Sheets("Sheet2")
Set ws_neg = wb.Sheets("Sheet3")
last_pos_val = 1
last_neg_val = 1
last_row = 20
For row = 1 To last_row
If ws_source.Cells(row,1) <> "" Then
If ws_source.Cells(row,1) > 0 Then
ws_pos.Cells(last_pos_val,1) = ws_source.Cells(row,1)
last_pos_val = last_pos_val + 1
Else
ws_neg.Cells(last_neg_val,1) = ws_source.Cells(row,1)
last_neg_val = last_neg_val + 1
End If
End If
Next
End Sub
Split Positive & Negative
Adjust the values in the constants section.
Both subs are needed. The first sub calls the second one.
The Code
Option Explicit
Sub SplitPN()
Const Source As String = "Sheet1"
Const Positive As String = "Sheet2"
Const Negative As String = "Sheet3"
Const FirstRow As Long = 1
Const SourceColumn As Long = 1
Const PositiveFirstCell As String = "A1"
Const NegativeFirstCell As String = "A1"
Dim rngSource As Range
Dim rngPositive As Range
Dim rngNegative As Range
With ThisWorkbook
With .Worksheets(Source)
Set rngSource = .Columns(SourceColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rngSource Is Nothing Then Exit Sub
If rngSource.Row < FirstRow Then Exit Sub
Set rngSource = .Range(.Cells(FirstRow, SourceColumn), rngSource)
End With
Set rngPositive = .Worksheets(Positive).Range(PositiveFirstCell)
Set rngNegative = .Worksheets(Negative).Range(NegativeFirstCell)
End With
SplitPosNeg rngSource, rngPositive, rngNegative
End Sub
Sub SplitPosNeg(SourceRange As Range, PositiveFirstCell As Range, _
NegativeFirstCell As Range)
Dim Source, Positive, Negative
Dim UB As Long, i As Long
Source = SourceRange
UB = UBound(Source)
ReDim Positive(1 To UB, 1 To 1)
ReDim Negative(1 To UB, 1 To 1)
For i = 1 To UBound(Source)
Select Case Source(i, 1)
Case Is > 0: Positive(i, 1) = Source(i, 1)
Case Is < 0: Negative(i, 1) = Source(i, 1)
End Select
Next
PositiveFirstCell.Resize(UB) = Positive
NegativeFirstCell.Resize(UB) = Negative
End Sub
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'm trying to search sheet_A for values in sheet_B / column A (starting from A2) and if they exist in sheet_A (column C, starting in C2) they get removed from sheet_A.
Sub Remover_Duplicados()
'Backup to another sheet
Const strSheetName As String = "BKP_sheet"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
Sheets("sheet_A").Range("A1:BK3500").Copy Destination:=Sheets(strSheetName).Range("A1")
'Search and destroy
Dim searchableRange As Range
Dim toRemoveRange As Range
Dim lLoop As Long
Set searchableRange = Worksheets("sheet_B").Range("A2", "A3500")
Set toRemoveRange = Worksheets("sheet_A").Range("C2", "C3500")
For lLoop = searchableRange.Rows.Count To 2 Step -1
If WorksheetFunction.CountIf(searchableRange, toRemoveRange(lLoop).Value) > 0 Then
Worksheets("sheet_A").Rows(lLoop).Delete shift:=xlUp
End If
Next lLoop
End Sub
Sheet A, B and the result:
Some don't get removed.
I've gone through your code and amended it slightly to be more dynamic with the ranges, I've also used an Array to populate the values to be removed and then looped though that array to decide whether the row should be deleted or not:
Sub Remover_Duplicados()
'Backup to another sheet
Const strSheetName As String = "BKP_sheet"
Dim wsA As Worksheet: Set wsA = ThisWorkbook.Worksheets("Sheet_A")
Dim wsB As Worksheet: Set wsB = ThisWorkbook.Worksheets("Sheet_B")
Dim arrToRemove()
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ThisWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
LastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
wsA.Range("A1:BK" & LastRowA).Copy Destination:=Sheets(strSheetName).Range("A1")
LastRowB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
arrToRemove = wsB.Range("A2:A" & LastRowB).Value
For iRow = LastRowA To 2 Step -1
For iArray = LBound(arrToRemove) To UBound(arrToRemove)
If wsA.Cells(iRow, "C").Value = arrToRemove(iArray, 1) Then
wsA.Rows(iRow).EntireRow.Delete shift:=xlUp
End If
Next iArray
Next iRow
End Sub
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