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
Related
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
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 can't get my head around this.
I have a data structure like this:
I would like to end up with something like this (in another sheet).
If column E is equivalent to 2, then the row should be copied to the other sheet, and the row with the same ID (Column A) the name in that row should be inserted in the final row.
Actually, I'm trying to merge/combine 2 rows, as seen in the picture, such that each ID number is only represented once in Sheet2.
Sub Test()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim i As Integer
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For i = 2 To last_row
If sh.Range("D" & i).Value = 2 Then
sh.Range("A1:G3").Copy _
Worksheets("sheet2").Range("A1")
End If
Next i
End Sub
For now, I can only copy a range.
And then I'm confused by which order to do the subtasks.
This is using a dictionary to make sure you don't copy multiples of the same id.
I'm assuming based on your example you always want the first instance of each id.
Dim sourcesh As Worksheet
Dim destsh As Worksheet
Set sourcesh = ThisWorkbook.Sheets("Sheet1")
Set destsh = ThisWorkbook.Sheets("Sheet2")
Dim i As Long
Dim j As Long
Dim lr As Long
With sourcesh
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
j = 1
For i = 2 To lr
If .Cells(i, 4).Value = 2 Then
If Not dict.exists(.Cells(i, 1).Value) Then
destsh.Cells(j, 1) = .Cells(i, 1)
destsh.Cells(j, 2) = .Cells(i, 2)
destsh.Cells(j, 4) = .Cells(i, 3)
destsh.Cells(j, 5) = .Cells(i, 4)
destsh.Cells(j, 6) = .Cells(i, 5)
destsh.Cells(j, 7) = .Cells(i, 6)
destsh.Cells(j, 8) = .Cells(i, 7)
dict.Add .Cells(i, 1).Value, j
j = j + 1
Else
destsh.Cells(dict(.Cells(i, 1).Value), 3) = .Cells(i, 2)
End If
End If
Next i
End With
I have a piece of code that worked for part but took ages to run (about 1700 rows). When I updated it to perform the whole function it now doesn't do anything- not sure where Ive gone wrong, and is there a version of code that would be quicker?
I'm still very new so do my code by searching what I want to do then bending it to suit.
I would like to check in column I for all dates that are less than the date in cell Z1. If any cells in the corresponding row say "Issued" I would like it to change to "Overdue".
Sub updateoverdue()
Application.ScreenUpdating = True
Dim j As Long, i As Long, lastRow1 As Long, lastRow2 As Long
Dim sh_1, sh_3 As Worksheet
Set sh_1 = Sheet6
Set sh_3 = Sheet6
lastRow1 = sh_1.UsedRange.Rows.Count
For j = 2 To lastRow1
Sheet6.Range("z1") = sh_1.Cells(j, 9).Value
lastRow2 = sh_3.UsedRange.Rows.Count
For i = 2 To lastRow2
If sh_3.Cells(i, 9).Value < Sheet6.Range("z1") And sh_3.Cells(i, 10).Value = "Issued" Then
sh_3.Cells(i, 10).Value = "Overdue"
End If
Next i
Next j
Application.ScreenUpdating = True
End Sub
I got it working on just Column J but then it failed when I added in the Issued part. Plus I cant get it to change more than one column (J to W).
Something like this might work for you:
Sub tgr()
Dim ws As Worksheet
Set ws = Sheet6
Dim TargetDate As Date
TargetDate = ws.Range("Z1").Value2
Dim DateList As Range
Set DateList = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))
If DateList.Row < 2 Then Exit Sub 'No dates
Dim DateCell As Range
For Each DateCell In DateList.Cells
If DateCell.Value2 > TargetDate And LCase(Trim(DateCell.Offset(, 1).Value)) = "issued" Then
DateCell.Offset(, 1).Value = "Overdue"
End If
Next DateCell
End Sub
I tested this and it worked fine:
Sub try()
Dim ws As Worksheet, lastrow As Long
Set ws = Sheet6
lastrow = ws.Cells(Rows.Count, 9).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lastrow
If ws.Cells(i, 9).Value < ws.Cells(1, 26).Value Then
ws.Cells(i, 10).Value = "Overdue"
ElseIf ws.Cells(i, 9).Value > ws.Cells(1, 26).Value Then
ws.Cells(i, 10).Value = "Issued"
Else
ws.Cells(i, 10).Value = "Due Today"
End If
Next i
Application.ScreenUpdating = True
End Sub
Or you can just use an excel formula and drop it down the entire column:
=IF(I1<$Z$1, "Issued","Overdue")