So im pretty new to VBA coding, and I'm trying to setup a commandbutton that when activated copys everything from sheet "Opties" to the sheet "BOM" from the column D and F that has a 1 in column with the titel "Totaal" and remove blanks.
So far this is my code
Sub Copy()
Dim c As Integer
Dim x As Integer
Dim y As Integer
Dim ws1 As Worksheet: Set ws1 = Sheets("Optie")
Dim ws2 As Worksheet: Set ws2 = Sheets("BOM")
Dim colNum As Integer
colNum = Worksheetfuntion.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
c = 1
x = -4 + colNum
y = -6 + colNum
Set rng1 = ws1.Column(colNum)
Set rng2 = ws2.Range("C5:C25000")
For Each c In ws1.rng1
rng1.Offset(0, x).Copy
rng2.Offset(0, 1).PasteSpecial xlPasteValues
rng1.Offset(0, y).Copy
rng2.Offset(0, 2).PasteSpecial xlPasteValues
Next c
End Sub
I think the following code should work:
'Try to avoid using names that Excel uses - you will sometimes "block" the
'native function, so call the subroutine "myCopy" or something else, but
'preferably not "Copy"
Sub myCopy()
Dim r1 As Long ' Use Long rather than Integer, because Excel
Dim r2 As Long ' now allows for more than 65536 rows
'Use Worksheets collection for worksheets, and only use the Sheets
' collection if you need to process Charts as well as Worksheets
Dim ws1 As Worksheet: Set ws1 = Worksheets("Optie") 'Should this be "Opties"?
Dim ws2 As Worksheet: Set ws2 = Worksheets("BOM")
Dim colNum As Long
colNum = WorksheetFunction.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
r2 = 5 ' I guessed that 5 is the first row you want to write to
'Loop through every row until the last non-empty row in Totaal column
For r1 = 1 To ws1.Cells(ws1.Rows.Count, colNum).End(xlUp).Row
'See if value in Totaal column is 1
If ws1.Cells(r1, colNum).Value = 1 Then
'I have guessed that your destination columns are D & E based on
'your Offset(0, 1) and Offset(0, 2) from column C
'I have guessed that your source columns are F & D based on the
'question mentioning those columns, and the offsets of -4 and -6
'in your current code - I assume based on "Totaal" being column J
'Change my guesses as necessary
'Copy values to destination from source
ws2.Cells(r2, "D").Value = ws1.Cells(r1, "F").Value
ws2.Cells(r2, "E").Value = ws1.Cells(r1, "D").Value
'Increment row counter for destination sheet
r2 = r2 + 1
End If
Next
End Sub
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
I am using Excel to produce reports for a billing system and I would like to use VBA to simplify the process of updating the excel. What I want to do is to use vlookup function to reflect columns (G:AI) from respective Named worksheets back to mastersheet. All sheets starts from row 4. (Row 3 is header)
So I'll further simplify the process as such:
VLOOKUP VBA (When changes made in the Named worksheets)
1. To enable Vlookup function in column (G:AI) in Mastersheet from Named worksheets ("John", "Charlie", "George")
2. As Mastersheet is a mixed data of John, Charlie and George, to input Vlookup formulas across column (G:AI) accordingly, then till last row of Mastersheet
3. My vlookup range will be from Named worksheets (John, Charlie, George), range (A1:AI) starting from column 7, row 4 till the end of the data.
ws1.Cells(r, c).Value = Application.VLookup(ws1.Cells(r, 1).Value, wsNames.Range("A1:AI500"), colnum, False)
Here are the codes I have so far. It's all I worked out (with help) as of now. Any help would be greatly appreciated.
My issue is, when running the code, vlookup values for ws11 is in the right place. However, vlookup values for ws12 and ws13 are shifted towards further left of the worksheet. For example,
while vlookup values for ws11 is in columns (A:AI) - the right columns
vlookup values for ws12 is in columns (AP:BR) - 7 columns from column AI and
vlookup values for ws13 is in columns (BY:DA) - 7 columns from column BR
Is there a line of code that I can insert to fix this?
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet, ws11 As Worksheet, ws12 As Worksheet, ws13 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws11 = wb.Sheets("Sheet11")
Set ws12 = wb.Sheets("Sheet12")
Set ws13 = wb.Sheets("Sheet13")
Dim colNo As Long, ARowNo as Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
Dim wsNames As Variant
For Each wsNames In Sheets(Array("sheet11", "sheet12", "sheet13"))
colNo = wsNames.Cells("4", Columns.Count).End(xlToLeft).Column
For for_col = 1 To colNo
ARowNo = wsNames.Cells(Rows.Count, "A").End(xlUp).row
For i = 1 To ARowNo
ws1.Cells(r, c).Value = Application.VLookup(ws1.Cells(r, 1).Value, wsNames.Range("A1:AI500"), colnum, False)
If IsError(ws1.Cells(r, c).Value) Then
ws1.Cells(r, c).Value = 0
End If
r = r + 1
Next
r = 4
colnum = colnum + 1
c = c + 1
Next
colnum = 7
Next wsNames
End Sub
I honestly can't see what can be causing the problem you describe based on the code posted. There is nothing substantially different in the code below - I have tidied up a couple of the loops and incorporated the last row variable. Let me know how you get on.
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Dim colNo As Long, ARowNo As Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
Dim wsNames As Variant
For Each wsNames In Sheets(Array("sheet11", "sheet12", "sheet13"))
colNo = wsNames.Cells("4", Columns.Count).End(xlToLeft).Column
ARowNo = wsNames.Cells(Rows.Count, "A").End(xlUp).Row
For for_col = 1 To colNo
For i = 1 To ARowNo
ws1.Cells(r, c).Value = Application.VLookup(ws1.Cells(r, 1).Value, wsNames.Range("A1:AI" & ARowNo), colnum, False)
If IsError(ws1.Cells(r, c).Value) Then
ws1.Cells(r, c).Value = 0
End If
r = r + 1
Next i
r = 4
colnum = colnum + 1
c = c + 1
Next for_col
colnum = 7
Next wsNames
End Sub
I'm trying to compare cell values between 2 Sheets (Sheet1 & Sheet2) to see if they match, and if they match move the matching values in Sheet1 to a pre-existing list (Sheet3) and delete the values in Sheet1 afterwards.
I'm using the reverse For Loop in Excel VBA, but everything works until the part where I start deleting the row using newrange1.EntireRow.Delete.
This throws a '424' Object Required Error in VBA and I've spent hours trying to solve this, I'm not sure why this is appearing. Am I selecting the row incorrectly? The object?
Would appreciate if anyone can point me to the correct direction.
Here's my code:
Sub Step2()
Sheets("Sheet1").Activate
Dim counter As Long, unsubListCount As Long, z As Long, x As Long, startRow As Long
counter = 0
startRow = 2
z = 0
x = 0
' Count Sheet3 Entries
unsubListCount = Worksheets("Sheet3").UsedRange.Rows.Count
Dim rng1 As Range, rng2 As Range, cell1 As Range, cell2 As Range, newrange1 As Range
' Select all emails in Sheet1 and Sheet2 (exclude first row)
Set rng1 = Worksheets("Sheet1").Range("D1:D" & Worksheets("Sheet1").UsedRange.Rows.Count)
Set rng2 = Worksheets("Sheet2").Range("D1:D" & Worksheets("Sheet2").UsedRange.Rows.Count)
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
'Cells(z, 4)
Set cell1 = Worksheets("Sheet1").Cells(z, "D")
For x = rng2.Count To startRow Step -1
Set cell2 = Worksheets("Sheet2").Cells(x, "D")
If cell1.Value = cell2.Value Then ' If rng1 and rng2 emails match
counter = counter + 1
Set newrange1 = Worksheets("Sheet1").Rows(cell1.Row)
newrange1.Copy Destination:=Worksheets("Sheet3").Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
End If
Next
Next
End Sub
Here's the error I'm getting:
Your inner loop produces a lot of step-by-step work that is better accomplished with Application.Match. Your use of .UsedRange to retrieve the extents of the values in the D columns is better by looking for the last value from the bottom up.
Option Explicit
Sub Step2()
Dim z As Long, startRow As Long
Dim rng2 As Range, wk3 As Worksheet, chk As Variant
startRow = 2
z = 0
Set wk3 = Worksheets("Sheet3")
' Select all emails in Sheet1 and Sheet2 (exclude first row)
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
End With
With Worksheets("Sheet1")
For z = .Cells(.Rows.Count, "D").End(xlUp).Row To startRow Step -1
chk = Application.Match(.Cells(z, "D").Value2, rng2, 0)
If Not IsError(chk) Then
.Cells(z, "A").EntireRow.Copy _
Destination:=wk3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Cells(z, "A").EntireRow.Delete
End If
Next
End With
End Sub
As noted by Ryan Wildry, your original problem was continuing the loop and comparing after deleting the row. This can be avoided by adding Exit For after newrange1.EntireRow.Delete to jump out of the inner loop once a match was found. I don't think you should 'reset cell1' as this may foul up the loop iteration.
I think what's happening is when you are deleting the row, you are losing the reference to the range Cell1. So I reset this after the deletion is done, and removed the reference to newRange1. Give this a shot, I have it working on my end. I also formatted the code slightly too.
Option Explicit
Sub Testing()
Dim counter As Long: counter = 0
Dim z As Long: z = 0
Dim x As Long: x = 0
Dim startRow As Long: startRow = 2
Dim Sheet1 As Worksheet: Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
Dim Sheet2 As Worksheet: Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Dim Sheet3 As Worksheet: Set Sheet3 = ThisWorkbook.Sheets("Sheet3")
Dim rng1 As Range: Set rng1 = Sheet1.Range("D1:D" & Sheet1.UsedRange.Rows.Count)
Dim rng2 As Range: Set rng2 = Sheet2.Range("D1:D" & Sheet2.UsedRange.Rows.Count)
Dim unsubListCount As Long: unsubListCount = Sheet3.UsedRange.Rows.Count
Dim cell1 As Range
Dim cell2 As Range
Dim newrange1 As Range
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
Set cell1 = Sheet1.Cells(z, 4)
For x = rng2.Count To startRow Step -1
Set cell2 = Sheet2.Cells(x, 4)
If cell1 = cell2 Then
counter = counter + 1
Set newrange1 = Sheet1.Rows(cell1.Row)
newrange1.Copy Destination:=Sheet3.Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
Set newrange1 = Nothing
Set cell1 = Sheet1.Cells(z, 4)
End If
Next
Next
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
Here is the Macro I've just written out, unfortunately it doesn't seem to do anything and I can't find the error! I am trying to copy the column with the header "Offset Acct" from sheet 1 (SAPDump) to sheet 2 (Extract) which is blank. Can anyone see explain to me why this isn't working? Fairly new to VBA so it's probably an easy fix. Cheers
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
' Define row and column counters
Dim r As Long
Dim c As Long
' Set last non-empty column
Dim lastCol As Long
lastCol = SAPDump.Cells(1, Columns.Count).End(xlToLeft).Column
' Set last non-empty row
Dim lastRow As Long
lastRow = SAPDump.Cells(Rows.Count, "A").End(xlUp).row
' Look a all columns
For c = 1 To c = lastCol
' Examine top column
If SAPDump.Cells(1, c).Value = "Offset Acct" Then
' Loop round all rows
For r = 1 To r = lastRow
' Copy column into A on Extract
Extract.Cells(r, 1) = SAPDump.Cells(r, c)
Next r
Else
End If
Next c
End Sub
You need to change these lines:
For c = 1 To c = lastCol
to
For c = 1 To lastCol
and
For r = 1 To r = lastRow
to
For r = 1 To lastRow
Edit:
A better way may be to do this:
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
'Define Heading range
Dim rHeadings As Range
Dim rCell As Range
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
'Set Heading range.
With SAPDump
Set rHeadings = .Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))
End With
'Look at each heading.
For Each rCell In rHeadings
If rCell.Value = "Offset Acct" Then
'If found copy the entire column and exit the loop.
rCell.EntireColumn.Copy Extract.Cells(1, 1)
Exit For
End If
Next rCell
End Sub
The set is not sure, how to run the same within excel macro.
Request you to send the same via .pdf formate.
Regards
Stalin.