I am new to VBA Coding but have managed to fumble my way through.
I have found this and modified to my requirements but I want to specify the range of columns to copy which are A to Q.
Any help would be appreciated.
Sub SplitData_ToPLCSheets()
'Split KEPServerCombined Column r into Separate Sheets ready for Export (PLC Name)
Const NameCol = "R"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim PLC As String
Excel_Tools.TurnEverythingOff ' Turn off Calc , Screen Updating and `enter code here`Calcs
Set SrcSheet = ThisWorkbook.Sheets("KEPServerCombined")
'Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).row
For SrcRow = FirstRow To LastRow
PLC = SrcSheet.Cells(SrcRow, NameCol).value
Set TrgSheet = Nothing
On Error Resume Next
Set TrgSheet = Worksheets(PLC)
On Error GoTo 0
If TrgSheet Is Nothing Then
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.name = PLC
SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
End If
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).row + 1
SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Excel_Tools.TurnEverythingOn ' Turn on Calc , Screen Updating and Calcs
End Sub
thanks for your help - finally sussed out an Answer which works but slow for 30000 rows
Sub SplitData_ToPLCSheets()
'Split KEPServerCombined Column r into Separate Sheets ready for Export (PLC Name)
Const SrcCol_PLC = "R"
Const SrcRow_Headers = 1
Const SrcRow_FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
TrgSheet.name = TrgName
SrcRange = "A" & Trim(Str(SrcRow_Headers)) & ":Q" & Trim(Str(SrcRow_Headers))
TrgRange = "A1"
SrcSheet.Range(SrcRange).Copy Destination:=TrgSheet.Range(TrgRange)
End If
' update the target row number to the first empty row on the target worksheet and copy data across
Set TrgSheet = Nothing
Set TrgSheet = Worksheets(TrgName)
TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, 1).End(xlUp).Offset(1).Row
SrcRange = "A" & Trim(Str(SrcRow)) & ":Q" & Trim(Str(SrcRow))
TrgRange = "A" & Trim(Str(TrgRow))
SrcSheet.Range(SrcRange).Copy Destination:=TrgSheet.Range(TrgRange)
SrcRow = SrcRow + 1
DoEvents
Loop
Excel_Tools.TurnEverythingOn ' Turn on Calc , Screen Updating and Calcs
End Sub
Related
I have a worksheet with sales data, I've managed to create Autofilter based on department and copied the results into the new sheet (Output). What I'm trying to achieve is that code will multiply the results of respective month by value in "Adjustment" row.
So the result is following
Is there a way how to process calculations within my code or I shall multiply each column in different Sub afterwards?
Dim Last_Row As Long
Dim DbExtract, DuplicateRecords As Worksheet
Dim WKS2 As Worksheet
Dim rn As Range
Set DbExtract = ThisWorkbook.Sheets("Data")
Set DuplicateRecords = ThisWorkbook.Sheets("Output")
Set WKS2 = ThisWorkbook.Sheets("Dashboard")
iMultiplier = WKS2.Range("Z18")
Application.ScreenUpdating = False
Last_Row = DuplicateRecords.Range("A" & Rows.Count).End(xlUp).Row + 1
DbExtract.Range("C3:R1500").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A" & Last_Row).PasteSpecial
DuplicateRecords.Range("$A$1:$P$400").AutoFilter Field:=3, Criteria1:=WKS2.Range("V2")
Set rn = DuplicateRecords.Range("G2:G500").SpecialCells(xlCellTypeVisible)
For Each cell In rn
iNewnumber = cell * iMultiplier
Next cell
End Sub
Here's an example:
Sub Tester()
Dim lastRow As Long, wb As Workbook
Dim wsData As Worksheet, wsOutput As Worksheet
Dim wsDash As Worksheet, rngVis As Range, numVisRows As Long
Dim rn As Range, rngAdj As Range, m As Long, adj, c As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data") 'consistent naming helps...
Set wsOutput = wb.Sheets("Output")
Set wsDash = wb.Sheets("Dashboard")
'iMultiplier = wsDash.Range("Z18") '?
Application.ScreenUpdating = False
Set rngVis = wsData.Range("C3:R1500").SpecialCells(xlCellTypeVisible)
numVisRows = rngVis.Cells.Count / rngVis.Columns.Count
rngVis.Copy
lastRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1 'start of pasted data
wsOutput.Range("A" & lastRow).PasteSpecial
Set rngAdj = wsDash.Range("C5:N5") 'for example
For m = 1 To rngAdj.Columns.Count 'loop the cells in the adjustments range
adj = rngAdj.Cells(m).Value 'adjustment value
If Len(adj) > 0 And IsNumeric(adj) Then 'have an adjustment to make?
'loop the relevant cells in the pasted data
For Each c In wsOutput.Cells(lastRow, "A").Offset(0, 2 + m).Resize(numVisRows).Cells
If Len(c.Value) > 0 And IsNumeric(c.Value) Then 'any thing to adjust?
c.Value = c.Value * adj
End If
Next c
End If
Next m
End Sub
I'm trying to compare column A in sheet2 to column A in sheet1 and when there's a match, copy the row from sheet1 to sheet3 with the same order. And if there is a repetition, it should be included too. I also need it to show the mismatching values empty. I did this macro but I can not allow the duplicates to be included.
Sub compareAndCopy()
Dim lastRowE As Long
Dim lastRowF As Long
Dim lastRowM As Long
Dim foundTrue As Boolean
' stop screen from updating to speed things up
Application.ScreenUpdating = False
lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
lastRowM = lastRowM + 1
Sheets("Sheet1").Rows(i).Copy Destination:= _
Sheets("Sheet3").Rows(lastRowM)
foundTrue = True
Exit For
End If
Next j
'If Not foundTrue Then
' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value)
'End If
Next i
' allow screen updating
Application.ScreenUpdating = True
End Sub
Group Data
Loops through probably unique values in column A of Sheet2.
For each cell value, it uses the Find and FindNext methods to find all the matching cells in column A of Sheet1.
Then it writes each of the cell values to a key, and using Union, combines each matching cell to a range object in the corresponding item.
Then it loops through the dictionary and copies the entire rows of each item (range) to Sheet3.
Finally, it clears the newly added values in column A of Sheet3.
The result in Sheet3 is data from Sheet1 grouped by the values in column A of Sheet2.
Option Explicit
Sub CompareAndCopy()
Const eName As String = "Sheet2"
Const eCol As String = "A"
Const efRow As Long = 1 ' don't you have headers?
Const fName As String = "Sheet1"
Const fCol As String = "A"
Const ffRow As Long = 1 ' don't you have headers?
Const mName As String = "Sheet3"
Const mCol As String = "B" ' "A" is empty!
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ews As Worksheet: Set ews = wb.Worksheets(eName)
Dim elRow As Long: elRow = ews.Cells(ews.Rows.Count, eCol).End(xlUp).Row
If elRow < efRow Then Exit Sub ' no data
Dim erg As Range: Set erg = ews.Cells(efRow, eCol).Resize(elRow - efRow + 1)
'Debug.Print erg.Address
Dim fws As Worksheet: Set fws = wb.Worksheets(fName)
Dim flRow As Long: flRow = fws.Cells(fws.Rows.Count, fCol).End(xlUp).Row
If flRow < ffRow Then Exit Sub ' no data
Dim frg As Range:
Set frg = fws.Cells(ffRow, fCol).Resize(flRow - ffRow + 1)
'Debug.Print frg.Address
Dim mws As Worksheet: Set mws = wb.Worksheets(mName)
Dim mifCell As Range
Set mifCell = mws.Cells(mws.Rows.Count, mCol).End(xlUp).Offset(1) _
.EntireRow.Columns("A") ' entire rows
Dim mfCell As Range: Set mfCell = mifCell
'Debug.Print mfCell.Address
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Application.ScreenUpdating = False
Dim frCount As Long: frCount = frg.Rows.Count
Dim eCell As Range
Dim eValue As Variant
Dim fCell As Range
Dim FirstAddress As String
For Each eCell In erg.Cells
eValue = eCell.Value
Set fCell = frg.Find(eValue, frg.Cells(frCount), xlFormulas, xlWhole)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If dict.Exists(eValue) Then
Set dict(eValue) = Union(dict(eValue), fCell)
Else
Set dict(eValue) = fCell
End If
Set fCell = frg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
End If
Next eCell
If dict.Count = 0 Then Exit Sub ' no data¸
Dim rg As Range
Dim Item As Variant
Dim irCount As Long
For Each Item In dict.Items
irCount = Item.Cells.Count
'Debug.Print Item.Address, irCount
Item.EntireRow.Copy mfCell.EntireRow
Set mfCell = mfCell.Offset(irCount)
Next Item
mifCell.Resize(mfCell.Row - mifCell.Row).ClearContents ' or .Clear
Application.ScreenUpdating = True
MsgBox "Data grouped.", vbInformation
End Sub
Sheet1 is a continuous list of everything being recorded and kept.
Sheet2 is an updated list that is retrieved, with updated lines and new lines. Within the lists in column A is a unique ID for every entry in numeric value.
I am trying to go through every unique ID in sheet2, look for a match in sheet1
if there is a match, replace that entire row values with the new values from sheet2
if there is no match it needs to be placed in the last blank row (+1 from xlUp).
I have tried other ways that are not below like using scripting.dictionary.
The way I am trying to do this results in every cell that the “for” is looking at to be true for the if not equal. Every item is posted multiple times below xlUp.
Sub test()
Dim enter As Worksheet
Dim take As Worksheet
Set enter = Worksheets("Sheet1")
Set take = Worksheets("Sheet2")
Dim a1 As Long
Dim b1 As Long
Dim c1 As Long
a1 = take.Cells(Rows.Count, 1).End(xlUp).Row
b1 = enter.Cells(Rows.Count, 1).End(xlUp).Row
c1 = enter.Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To a1 'this statement works fine to find the matching value to replace.
For K = 1 To b1
If take.Cells(i, 1) = enter.Rows(K, 1) Then
enter.Rows(i).EntireRow = take.Rows(K).EntireRow.Value
End If
Next
Next
'below is other things i have tried
'For I = 1 To a1
' For J = 1 To b1
' If enter.Cells(J, 1) <> take.Cells(I, 1) Then
' enter.Rows(c1).EntireRow = take.Rows(I).EntireRow.Value
' c1 = c1 + 1
' End If
' Next
'Next
'For i = 1 To a1
' For j = 1 To b1
' If take.Cells(i, 1) = enter.Cells(j, 1) Then
' enter.Rows(j).EntireRow = take.Rows(i).EntireRow.Value
' GoTo Skip
' ElseIf j = b1 Then
' enter.Rows(c1).EntireRow = take.Rows(i).EntireRow.Value
' c1 = c1 + 1
' End If
' Next
'Skip:
'Next
End Sub
hy
Public Sub MyCopy()
Dim wsSource As Worksheet, wsTarget As Worksheet
Set wsSource = ThisWorkbook.Worksheets("ws1")
Set wsTarget = ThisWorkbook.Worksheets("ws2")
Dim col As String
col = "A"
Dim i As Long, targetRow As Long, q As Long
Dim sourceRange As Range
With wsSource
For i = 1 To .Cells(.Rows.Count, col).End(xlUp).Row
Set sourceRange = .Range(col & i)
targetRow = GetDataRow(wsTarget, col, sourceRange.value)
For q = 0 To 30
wsTarget.Range(col & targetRow).Offset(0, q).value = sourceRange.Offset(0, q).value
Next q
Next i
End With
End Sub
Private Function GetDataRow(ws As Worksheet, col As String, value As String) As Long
With ws
Dim lastRow As Long, i As Long
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
For i = 1 To lastRow
If .Range(col & i).value = value Then
GetDataRow = i
GoTo exitFunc
End If
Next i
GetDataRow = lastRow + 1
End With
exitFunc:
End Function
Update Worksheet (For Each ... Next, Application.Match)
Option Explicit
Sub UpdateWorksheet()
Const sName As String = "Sheet2"
Const sFirst As String = "A1"
Const dName As String = "Sheet1"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slCell As Range
Set slCell = sws.Cells(sws.Rows.Count, sws.Range(sFirst).Column).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sFirst, slCell)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlCell As Range:
Set dlCell = dws.Cells(dws.Rows.Count, dws.Range(dFirst).Column).End(xlUp)
Dim drg As Range: Set drg = dws.Range(dFirst, dlCell)
Application.ScreenUpdating = False
Dim sCell As Range
Dim cIndex As Variant
For Each sCell In srg.Cells
cIndex = Application.Match(sCell.Value, drg, 0)
If IsNumeric(cIndex) Then
drg.Cells(cIndex).EntireRow.Value = sCell.EntireRow.Value
Else
Set dlCell = dlCell.Offset(1)
dlCell.EntireRow.Value = sCell.EntireRow.Value
End If
Next sCell
Application.ScreenUpdating = True
End Sub
I have two sheets; SheetA and SheetB where I want to find a match between all parameter IDs in SheetA (Column B) and the corresponding parameter ID's in SheetB (Column A). If there is a match, then print corresponding parameter values from sheetB (Column E) into SheetA (Column C). This part works fine, but instead of leaving all cases where there is NO match (IsError) blank, I want a "NA" into the blank cell in SheetA - Column C next to all active cells in SheetA - Column B.
What to write into my code between If IsError(rowNumber) Then and Else?
Private Sub CommandButtona1_Click()
Application.ScreenUpdating = False
iRow = 1
eRow = 4000
For I = iRow To eRow
rowNb = Application.Match(Worksheets("SheetB").Range("A" & I), Worksheets("SheetA").Columns(2), 0)
If IsError(rowNb) Then
'How to write NA where IsError(rowNb) is True?
Else
Worksheets("SheetA").Range("C" & rowNb).Value = Worksheets("SheetB").Range("E" & I).Value
End If
Next I
Application.ScreenUpdating = True
End Sub
well on start set variables for worksheets like below
dim wb as workbook
dim wsA as worksheet, wsB as worksheet
set wb=thisworkbook
set wsA = wb.worksheets("SheetA") ' or set wsA = wb.worksheets(sheet1.name)
set wsB = wb.worksheets("SheetB") ' or set wsB = wb.worksheets(sheet2.name)
cheange eRow = 4000 to eRow=wsB.range("A" & rows.count).end(xlup).row
and then check condition If IsError(rowNb) =true Then
full code
Private Sub CommandButtona1_Click()
Application.ScreenUpdating = False
dim wb as workbook
dim wsA as worksheet, wsB as worksheet
set wb=thisworkbook
set wsA = wb.worksheets("SheetA") ' or set wsA = wb.worksheets(sheet1.name)
set wsB = wb.worksheets("SheetB") ' or set wsB = wb.worksheets(sheet2.name)
iRow = 1 ' if u have headers iRow should be 2
eRow=wsB.range("A" & rows.count).end(xlup).row
For I = iRow To eRow
rowNb = Application.Match(wsB.Range("A" & I), wsA.Columns(2), 0)
If IsError(rowNb)= true Then
'How to write NA where IsError(rowNb) is True?
wsA.Range("C" & rowNb)="n/a" ' "NA" etc
Else
wsA.Range("C" & rowNb).Value = wsB.Range("E" & I).Value
End If
Next I
Application.ScreenUpdating = True
End Sub
*// edited
Private Sub CommandButtona1_Click()
Application.ScreenUpdating = False
dim wb as workbook
dim wsA as worksheet, wsB as worksheet
dim wanted as string
dim findRng as range
set wb=thisworkbook
set wsA = wb.worksheets("SheetA") ' or set wsA = wb.worksheets(sheet1.name)
set wsB = wb.worksheets("SheetB") ' or set wsB = wb.worksheets(sheet2.name)
iRow = 1 ' if u have headers iRow should be 2
eRow=wsB.range("A" & rows.count).end(xlup).row
For I = iRow To eRow
wanted =wsA.cells(i,2)
set findRng = wsB.range("A:A").find(wanted, lookat:=xlpart)
If findRng is nothing Then
'How to write NA where IsError(rowNb) is True?
wsA.cells(i,3)="n/a" ' "NA" etc
Else
wsA.cells(i,3) = wsB.cells(findRng.row, 5)
End If
Next I
Application.ScreenUpdating = True
End Sub
I am trying to does the following:
Compare the value (a string of characters) that is stored in column B of worksheet "State = Closed", to all the values in column A of another worksheet called "Match List".
Delete any row in the "State = Closed" that does not have a match to the corresponding "Match List" value.
The code needs to work with any length (as the number of rows will change) list in "Match List", as well as any length "State = Closed" worksheet.
Sub ListRemove()
Application.ScreenUpdating = False
Dim i As Integer
Dim b As Integer
Dim Lastrow As Long
Dim Lastrowb As Long
Dim Del As Variant
Worksheets("Match List").Activate
Set Del = Range("A1:A67") '<--- This needs to be modified to work with any length Match List
Lastrowb = Worksheets("State = Closed").Cells(Rows.Count, "A").End(xlUp).Row
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
For b = 1 To Lastrowb
If Worksheets("State = Closed").Cells(i, 2).Value <> Del(b) Then
Worksheets("State = Closed").Rows(i).EntireRow.Delete
End If
Next
Next
Application.ScreenUpdating = True
Worksheets("State = Closed").Activate
End Sub
This deletes every row in the "State = Closed" worksheet instead of just the rows that do not contain a corresponding value in the Match List worksheet.
Find my code below. Two for-loops to check for each value if there is an identical entry in any cell of the second sheet.
Sub List_Remove()
Dim i As Integer
Dim j As Integer
Dim k As Boolean
Dim shA As Worksheet
Dim shB As Worksheet
Set shA = Sheets("Sheet1") 'Worksheet that you want to compare with
Set shB = Sheets("Sheet2") 'Worksheet you want to delete rows from
For i = shB.UsedRange.Rows.Count To 1 Step -1
k = False
For j = 1 To shA.UsedRange.Rows.Count
If shB.Cells(i, 1).Value = shA.Cells(j, 1).Value Then
k = True
End If
Next
If k = False Then
shB.Rows(i).Delete
End If
Next
EndSub
This code is tested. Note use of working directly with objects.
Option Explicit
Sub ListRemove()
Application.ScreenUpdating = False
Dim matchList As Worksheet
Set matchList = Worksheets("Match List")
Dim matchRange As Range
Set matchRange = matchList.Range("A1:A" & matchList.Cells(matchList.Rows.Count, 1).End(xlUp).Row)
Dim closedList As Worksheet
Set closedList = Worksheets("State = Closed")
Dim searchRows As Long
searchRows = closedList.Cells(closedList.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = searchRows To 1 Step -1
If IsError(Application.Match(closedList.Cells(i, 1).Value, matchRange, 0)) Then
closedList.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Delete Rows (Union)
The Code
Option Explicit
Sub ListRemove()
Application.ScreenUpdating = False
' Constants
Const mlName As String = "Match List"
Const mlFR As Long = 1
Const mlCol As Variant = "A" ' e.g. 1 or "A"
Const scName As String = "State = Closed"
Const scFR As Long = 1
Const scCol As Variant = "B" ' e.g. 1 or "A"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Match List
Dim ml As Worksheet: Set ml = wb.Worksheets(mlName)
Dim mlLR As Long: mlLR = ml.Cells(ml.Rows.Count, mlCol).End(xlUp).Row
Dim Del As Variant
Del = ml.Range(ml.Cells(mlFR, mlCol), ml.Cells(mlLR, mlCol)).Value
' State = Closed
Dim sc As Worksheet: Set sc = wb.Worksheets(scName)
Dim scLR As Long: scLR = sc.Cells(sc.Rows.Count, scCol).End(xlUp).Row
Dim rng As Range
Set rng = sc.Range(sc.Cells(scFR, scCol), sc.Cells(scLR, scCol))
' Collecting Cells
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If IsError(Application.Match(cel.Value, Del, 0)) Then
GoSub collectCells
End If
Next
' Deleting Rows
'If Not URng Is Nothing Then URng.EntireRow.Delete
' First test with Hiding Rows.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
Application.ScreenUpdating = True
sc.Activate
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub