Problem:
I am working on the "Extract" workbook and expect to copy some data from the "Sales2021" workbook which is closed. The point is: when I have 2 workbooks open, the code works perfectly but when I close "Sales2021", it runs into error. My purpose is to modify the script so that even when "Sales2021" is closed, it still works.
Code explanations:
"Extract" contains 2 sheets, sheet1 and sheet2 (sheet2 is the destination sheet where I want to copy data from "Sales2021" to). "Sales2021" has only "Master_data" sheet. I want to check whether cells (1,2) and (1,3) of sheet1 match data in column 2 and 3 of "Master_data".
Sub Extract()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in Column A
With Workbooks("Sales2021.xlsm").Sheets("Master_data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Copy headers
Worksheets("Extract").Rows(1).Value = Workbooks("Sales2021.xlsm").Sheets("Master_data").Rows(1).Value
'first row number'
With Worksheets("Sheet2")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Workbooks("Sales2021.xlsm").Sheets("Master_data")
If (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And .Cells(i, 3).Value = Worksheets("Sheet1").Cells(1, 2).Value) Or (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And Worksheets("Sheet1").Cells(1, 2).Value = "") Then
.Rows(i).Copy Destination:=Worksheets("Sheet2").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
I haven't really tested this. The code checks if the workbooks is already open and opens it if needed.
Public Sub Extract()
Const EXPECTED_PATH As String = "C:\Users\Laura\Test\Sales2021.xlsm.xlsx"
'Check if the file is already open, if it isn't then open it.
Dim ReportBk As Workbook
Dim wrkBk As Workbook
For Each wrkBk In Application.Workbooks
If wrkBk.FullName = EXPECTED_PATH Then
Set ReportBk = wrkBk
Exit For
End If
Next wrkBk
If wrkBk Is Nothing Then
Set ReportBk = Workbooks.Open(EXPECTED_PATH)
End If
Dim Source_LastRow As Long
With ReportBk.Worksheets("Master_data")
Source_LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Extract").Rows(1).Value = .Rows(1).Value
End With
Dim Target_LastRow As Long
With ThisWorkbook.Worksheets("Sheet2")
Target_LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With ReportBk.Worksheets("Master_data")
Dim i As Long
For i = 1 To Source_LastRow
If (.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And _
.Cells(i, 3).Value = Worksheets("Sheet1").Cells(1, 2).Value) Or _
(.Cells(i, 2).Value = Worksheets("Sheet1").Cells(1, 1).Value And _
Worksheets("Sheet1").Cells(1, 2).Value = "") Then
.Rows(i).Copy Destination:=Worksheets("Sheet2").Cells(Target_LastRow, 1)
Target_LastRow = Target_LastRow + 1
End If
Next i
End With
End Sub
Related
I am not very familiar with VBA and I need help with programming a code to do the following:
On Button Click in Sheet 1
Copy values from Column A if value =1 to worksheet 2 into column A.
If the value = 2 then copy it to worksheet 3 into column A.
This is my current code.
Sub Mandat1_Click()
For Each Cell In Range("A2:A81")
If Cell.Value = 1 Then
Sheets(3).Range("C2:C81").Value = Sheets(1).Range("A2:A81").Value
End If
Next Cell
End Sub
This is my best guess at what you are trying to do.
Sub moveData()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets(1)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets(2)
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Worksheets(3)
Dim r As Integer
For r = 2 To 81
If ws1.Cells(r, 1).Value = 1 Then
ws2.Cells(r, 1).Value = ws1.Cells(r, 1).Value
ElseIf ws1.Cells(r, 1).Value = 2 Then
ws3.Cells(r, 1).Value = ws1.Cells(r, 1).Value
End If
Next r
End Sub
Sub TransferData()
Dim lastrow As Long, erow As Long
'Check last filled row
lastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheets(1).Cells(i, 1).Value = 1 Then
'Copies data from from Sheet 1 column 1
Sheets(1).Cells(i, 1).Copy
erow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'Pastes data in Sheet 2 column 1
Sheets(1).Paste Destination:=Sheets(2).Cells(erow + 1, 1)
Sheets(1).Cells(i, 1).Copy
eerow = Sheets(6).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(1).Paste Destination:=Sheets(6).Cells(eerow + 1, 1)
End If
Next i
End Sub
I am getting a subscript out of range error on the first if statement.
I had this working when it was all within the same Workbook just different sheets
I want it to reference a different workbook to gets it data from.
I did the tools -> reference -> "Report" workbook that way I know it is open.
Sub update_cell1_InProcess()
Dim lRow As Long
b = 31
lRow = Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 5).Value = Workbooks("Big screen.xlsm").Sheets("CELL_1").Cells()(1, 2).Value Then 'B1
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 1).Value = Workbooks("Big screen.xlsm").Sheets("CELL_1").Cells()(1, 1).Value Then 'A1
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 6).Value <> "" Then 'not blank
If Workbooks("Report.xlsm").Sheets("CopyDatabase").Cells(i, 8).Value = "" Then
Workbooks("Report.xlsm").Sheets("CopyDatabase").Rows(i).Copy
Workbooks("Big screen.xlsm").Sheets("SHEET1").Activate
Workbooks("Big screen.xlsm").Sheets("SHEET1").Cells(b + 1, 1).Select
ActiveSheet.Paste
b = b + 1
End If
End If
End If
End If
Next
Application.CutCopyMode = False
End Sub
Just different If statements but code that worked in same workbook different sheets
Sub update_cell1_completed()
Dim lRow As Long
b = 1
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If Worksheets("TEST").Cells(i, 5).Value = Worksheets("CELL_1").Cells()(1, 2).Value Then 'B1
If Worksheets("TEST").Cells(i, 1).Value = Worksheets("CELL_1").Cells()(1, 1).Value Then 'A1
If Worksheets("TEST").Cells(i, 6).Value <> "" Then 'not blank
If Worksheets("TEST").Cells(i, 8).Value <> "" Then 'not blank
Worksheets("TEST").Rows(i).Copy
Worksheets("SHEET1").Activate
Worksheets("SHEET1").Cells(b + 1, 1).Select
ActiveSheet.Paste
b = b + 1
End If
End If
End If
End If
Next
Application.CutCopyMode = False
End Sub
Here's your code refactored to include proper object references and simply the multi-if statement. See if you get the same error, and if so, let us know which line is erroring for you:
EDIT: Per comments, updated references to Workbooks("Big screen.xlsm") to instead be ThisWorkbook
Sub update_cell1_InProcess()
Dim wbRprt As Workbook: Set wbRprt = Workbooks("Report.xlsm")
Dim wbScrn As Workbook: Set wbScrn = ThisWorkbook
Dim wsDB As Worksheet: Set wsDB = wbRprt.Worksheets("CopyDatabase")
Dim wsC1 As Worksheet: Set wsC1 = wbScrn.Worksheets("CELL_1")
Dim wsS1 As Worksheet: Set wsS1 = wbScrn.Worksheets("SHEET1")
Dim lLastRow As Long: lLastRow = wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).Row
Dim lDestRow As Long: lDestRow = 32
Dim i As Long
For i = 1 To lLastRow
If wsDB.Cells(i, "E").Value = wsC1.Range("B1").Value _
And wsDB.Cells(i, "A").Value = wsC1.Range("A1").Value _
And Len(wsDB.Cells(i, "F").Value) > 0 _
And Len(wsDB.Cells(i, "H").Value) > 0 Then
wsDB.Rows(i).Copy wsS1.Cells(lDestRow, "A")
lDestRow = lDestRow + 1
End If
Next i
Application.CutCopyMode = False
End Sub
I'm attempting to match values between two sheets and if found and the conditions are met, perform the action of changing the cell colour.
PROBLEM:
I'm getting an error with my For...Next loop, even though I thought I have a NEXT for each FOR statement. Not sure what I've done wrong.
Also, I'm not sure my counters are setup correctly to accurately scan through each sheet/column needed. Any help would be appreciated.
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Ref1")
Set ws2 = wb.Sheets("TRA")
lastrow = Sheets("Ref1").Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = Sheets("TRA").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Ref1").Activate
i = 2
k = 2
For i = 2 To lastrow
For k = 2 To lastrow2
If Cells(i, 4).Value = "Active" Then
If ws.Cells(i, 18).Value = ws2.Cells(i, 1).Value And (ws2.Cells(i, 23).Value <> "Cancelled" Or ws2.Cells(i, 23).Value <> "Completed") Then
Cells(i, 20).Interior.ColorIndex = 9
End If
Next
Next
End Sub
Quick Repair
To better understand the code, it is often preferable to use letters,
instead of numbers, for columns.
The Code
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
Dim i As Long
Dim k As Long
' Use ThisWorkbook instead of ActiveWorkbook, if the code is
' in the same workbook where these sheets are.
With ActiveWorkbook
Set ws = .Worksheets("Ref1")
Set ws2 = .Worksheets("TRA")
End With
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If ws.Cells(i, "D").Value = "Active" Then
For k = 2 To lastrow2
If ws.Cells(i, "R").Value = ws2.Cells(k, "A").Value _
And ws2.Cells(k, "W").Value <> "Cancelled" _
And ws2.Cells(k, "W").Value <> "Completed" Then
ws.Cells(i, "T").Interior.ColorIndex = 9 ' Brown
Exit For
End If
Next
End If
Next
End Sub
I'm new in the VBA. its there any way to connect with sheet 2 and sheet 1. See the picture below:
Sheet 1
Sheet 2
I tried using this VBA code but its not working.
Sub Finddata()
Dim x As Long
Sheets("Sheet2").Activate
For x = 2 To Sheets("Sheet2").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
For y = 2 To 5
On Error Resume Next
Cells(x, y).Value = Application.WorksheetFunction.VLookup(Cells(x, "A").Value, Sheets("Sheet1").Range("A2:F18"), y = 1, 0)
Next y
Next x
End Sub
How about the following, this uses the .Find method to search for the given value in Sheet1 and then return by offsetting:
Sub Finddata()
Dim x As Long, LastRow As Long
Dim FindValues As Range
Dim ws As Worksheet: ws = Sheets("Sheet1")
Dim ws2 As Worksheet: ws2 = Sheets("Sheet2")
'above declare variables
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Sheet2
For x = 2 To LastRow 'loop from row 2 to last on Sheet2
Set FindValues = ws.Range("A:A").Find(What:=ws2.Cells(x, 1).Value, Lookat:=xlWhole)
'use the Find method to search for the value in Sheet1
If Not FindValues Is Nothing Then 'if found
ws2.Cells(x, 2).Value = FindValues.Offset(0, 1).Value
ws2.Cells(x, 3).Value = FindValues.Offset(0, 2).Value
ws2.Cells(x, 4).Value = FindValues.Offset(0, 3).Value
ws2.Cells(x, 5).Value = FindValues.Offset(0, 4).Value
ws2.Cells(x, 6).Value = FindValues.Offset(0, 5).Value
'pass the values into Sheet2
End If
Next x
End Sub
I have a very basic question. I have a large Workbook with alot of listed information. I want to take out some of the information into a new workbook and sort it on the different worksheets. I am having some problems with making the code understand which tab I want the information to be placed into. the strName = Range(cell value) do not work and I do not really know what I am doing wrong. How can I make this works? Sorry about the very messy code.
Private Sub CommandButton1_Click()
Dim strName As String
Set sourceWq = Workbooks("SD KPIs 2014 onwards").Worksheets("VQN+Concessionn")
Set front = Workbooks("databank progging").Worksheets("Frontpage")
For l = 5 To 30
For i = 2 To 250000 'Goes through the sourceWq workbook
If front.Cells(l, 13).Value = sourceWq.Cells(i, 24).Value Then 'Finds correct supplier
strName = Range("l,13")
Sheets(strName).Select 'Selects the correct worksheet for the supplier
For j = 4 To 15 'Month
If sourceWq.Cells(i, 33).Value = Cells(7, j).Value Then
For n = 8 To 11 'The type of NCR
If sourceWq.Cells(i, 27).Value = Cells(n, 2).Value Then
Cells(n, j).Value = Cells(n, j).Value + 1
Else: End If
Next n
Else: End If
Next j
Else: End If
Next i
Next l
End Sub
I slightly rewrote your code without this loop For i = 2 To 250000 (I use Find method instead):
Private Sub CommandButton1_Click()
Dim strName As String
Dim sourceWq As Worksheet, front As Worksheet, sh As Worksheet
Dim rng As Range
Dim firstAddress As String
Dim wb1 As Workbook, wb2 As Workbook
Dim l As Long, i As Long, j As Long
Set wb1 = Workbooks("SD KPIs 2014 onwards")
Set wb2 = Workbooks("databank progging")
Set sourceWq = wb1.Worksheets("VQN+Concessionn")
Set front = wb2.Worksheets("Frontpage")
For l = 5 To 30
With sourceWq.Range("X2:X250000")
Set rng = .Find(front.Cells(l, 13).Value, LookIn:=xlValues)
End With
If Not rng Is Nothing Then
firstAddress = rng.Address
Do
strName = front.Cells(l, 13).Value
Set sh = wb2.Worksheets(strName)
With sh
For j = 4 To 15 'Month
If rng.Offset(, 9).Value = .Cells(7, j).Value Then
For n = 8 To 11 'The type of NCR
If rng.Offset(, 3).Value = .Cells(n, 2).Value Then
.Cells(n, j).Value = .Cells(n, j).Value + 1
End If
Next n
End If
Next j
End With
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> firstAddress
End If
Next l
End Sub
strName = Range("l,13") should read strName = Cells(l,13)