Sub BSRange()
Set ws1 = ThisWorkbook.Worksheets("Balance")
Set ws2 = ThisWorkbook.Worksheets("Summary")
Set ws3 = ThisWorkbook.Worksheets("Cash")
Dim Lastcol As Long
Dim Lastrow As Long
Dim colname As String
Lastcol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
For i = 2 To Lastcol
With ws1
colname = Split(Cells(, i).Address, "$")(1)
Lastrow = .Cells(.Rows.Count, colname).End(xlUp).Row
End With
With ws3
Range(Cells(4, i), Cells(Lastrow, i)).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 1)
End With
With ws1
Range(Cells(4, i), Cells(Lastrow, i)).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next i
End Sub
The data does not copy and the compiler shows no error in the code. Also, when I try to get rid of With in the For loop, using SheetName in the prefix, then it gives me an error.
Try with these edits. I think you just need to be more careful about qualifying worksheets when you are working across multiple. For instance Cell() will call on the active worksheet, .Cells() will call on the workbook qualified in you With statement.
Sub BSRange()
Set ws1 = ThisWorkbook.Worksheets("Balance")
Set ws2 = ThisWorkbook.Worksheets("Summary")
Set ws3 = ThisWorkbook.Worksheets("Cash")
Dim Lastcol As Long
Dim Lastrow As Long
Dim colname As String
Lastcol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
For i = 2 To Lastcol
With ws1
colname = Split(.Cells(, i).Address, "$")(1)
Lastrow = .Cells(.Rows.Count, colname).End(xlUp).Row
End With
With ws3
.Range(.Cells(4, i), .Cells(Lastrow, i)).Copy ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1, 1)
End With
With ws1
.Range(.Cells(4, i), .Cells(Lastrow, i)).Copy ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next i
End Sub
Related
Scenario: -There are 2 sheets being compared. Range for Sheet1 is B2:B and for Sheet2 is C2:C.
Requirement:
Sheet1 B2 = Sheet2 C2
Sheet1 B3 = Sheet2 C3 and so on...
See my existing code below:
Sub MessageCode()
Dim FoundBlank1 As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim MyRange As Range, MyCell As Range, MyRange2 As Range, MyCell2 As Range
Set MyRange = ws.Range("B2:B" & ws.Range("B" & ws.Rows.Count).End(xlUp).Row)
Set MyRange2 = ws2.Range("C2:C" & ws2.Range("C" & ws2.Rows.Count).End(xlUp).Row)
Set MyCell2 = MyRange2
For Each MyCell In MyRange
If MyCell.Value <> Worksheets("Sheet2").Range("C2").Value Then
MyCell.Copy
Worksheets("Sheet3").Select
Set FoundBlank1 = Range("A1:A1000").Find(What:="", lookat:=xlWhole)
FoundBlank1.Select
Selection.PasteSpecial xlPasteValues
ActiveCell.Offset(0, 1).Value = "Incorrect Value."
End If
Next MyCell
End Sub
I've added in some extra message box if the number of rows of sheet 1 and 2 are not the same.
Try this:
Sub Messagecode()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastrow1 As Integer
Dim lastrow2 As Integer
dim lastrow3 as integer
Dim i As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
ws1.Activate
lastrow1 = Cells(Rows.Count, 2).End(xlUp).Row
ws2.Activate
lastrow2 = Cells(Rows.Count, 3).End(xlUp).Row
If lastrow1 <> lastrow2 Then
MsgBox ("number of rows in Sheet1 is not equal to number of rows in Sheet2")
End If
For i = 2 To lastrow1
If ws1.Cells(i, 2) <> ws2.Cells(i, 3) Then
ws2.Cells(i, 3).Copy
Worksheets("Sheet3").Activate
lastrow3 = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lastrow3, 1).Offset(1, 0).Activate
ActiveSheet.Paste
Cells(lastrow3, 1).Offset(1, 1) = "incorrect value"
End If
ws1.Activate
Next i
End Sub
You only need to set the last row for sheet1 and sheet3. run a loop from 2 to the lastrow and compare Sheet1.columnB with Sheet2.columnC if <> then copy the value in Sheet1 to Sheet3, offset 1 cell to the right and paste your text. You add +1 to the last row in Sheet3 so you don't keep writing over the same cell...
Dim i As Long
Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
Dim lRow3 As Long
lRow3 = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lRow
If Sheet1.Cells(i, "B").Value <> Sheet2.Cells(i, "C").Value Then
Sheet3.Cells(lRow3, "A").Value = Sheet1.Cells(i, "B").Value
Sheet3.Cells(lRow3, "A").Offset(, 1).Value = "Incorrect Value."
End If
lRow3 = lRow3 + 1
Next i
This would be the data, I would like to be able to take all the PP from sheet4 and paste them into sheet PDH_Handvoer in a specific range say A11:A22. Then also take the FA and paste them into the same sheet but with range A30:A42 and so one for each of the letters.
so far this is the code, but it isnt doing what I need it to
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet4")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("PDH_Handover")
Dim LRow1 As Long, LRow2 As Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To LRow1
If ws1.Cells(i, 1) = "pp" Then
ws1.Range(Cells(i, 2), Cells(i, 5)).Copy
ws2.Range("A" & LRow2 + 1).PasteSpecial xlPasteValues
End If
Next
End Sub
Your code is working, you just need to re-grab the LRow2 value after you paste a new line - otherwise you're always overwriting your first line (and in you case, your last copied line is blank, so it looks like nothing is happening when it actually is).
I've also added Application.CutCopyMode = False to the end, as good practice (that clears the clipboard).
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet4")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("PDH_Handover")
Dim LRow1 As Long, LRow2 As Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To LRow1
If ws1.Cells(i, 1) = "PP" Then
ws1.Range(Cells(i, 2), Cells(i, 5)).Copy
ws2.Range("A" & LRow2 + 1).PasteSpecial xlPasteValues
'Get new last row value
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
End If
Next
Application.CutCopyMode = False
End Sub
Rather, let's just get rid of Copy/Paste altogether, as it's best to avoid syntax that relies on ActiveSheet:
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet4")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("PDH_Handover")
Dim LRow1 As Long, LRow2 As Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To LRow1
If ws1.Cells(i, 1) = "PP" Then
ws2.Range(ws2.Cells(LRow2 + 1, 1), ws2.Cells(LRow2 + 1, 4)).Value = _
ws1.Range(ws1.Cells(i, 2), ws1.Cells(i, 5)).Value
'Get new last row value
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
End If
Next
End Sub
If we get the right value of LRow2 in the first time, I prefer to LRow2 = LRow2 + 1
but not to End(xlUp).row
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRow1 As Long, LRow2 As Long, i As Long
Set ws1 = Application.ThisWorkbook.Sheets("Sheet4")
Set ws2 = Application.ThisWorkbook.Sheets("PDH_Handover")
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).row
For i = 2 To LRow1
If ws1.Cells(i, 1) = "PP" Then
ws1.Range(Cells(i, 2), Cells(i, 5)).Copy
ws2.Range("A" & LRow2 + 1).PasteSpecial xlPasteValues
'Get new last row value
LRow2 = LRow2 + 1
End If
Next
End Sub
Trying to use vba to write countifs function but got an error of object doesn't support this property or method. (Run-time error 438)
Sub counters()
Dim rng, rng2, rng3, rng4 As Range
Dim lrow, lr, lr2, lr3, lr4 As Long
Dim ws, ws1 As Worksheet
Set ws = Sheets("Data")
Set ws1 = Sheets("Table E-1 Zip Codes PIF")
lr = ws.Cells(Cells.Rows.Count, "D").End(xlUp).Row
lr2 = ws.Cells(Cells.Rows.Count, "X").End(xlUp).Row
lr3 = ws.Cells(Cells.Rows.Count, "Y").End(xlUp).Row
lr4 = ws.Cells(Cells.Rows.Count, "AE").End(xlUp).Row
lrow = ws1.Cells(Cells.Rows.Count, "B").End(xlUp).Row
'zip code
Set rng = ws.Range("D2:D" & lr)
'county
Set rng2 = ws.Range("X2:X" & lr2)
'Region
Set rng3 = ws.Range("Y2:Y" & lr3)
'policy form
Set rng4 = ws.Range("AE2:AE" & lr4)
For i = 5 To lrow - 1
Worksheets("Table E-1 Zip Codes PIF").Cells(i, 4).Value = Application.WorksheetFunction.CountIfs(ws.rng, ws1.Cells(i, 2).Value, ws.rng2, ws1.Cells(i, 3).Value, ws.rng3, "NW", ws.rng4, "Basic Choice")
Next i
End Sub
Excel function works fine but need to use vba to automate the process. Tried recording the macro but it gives reference and wasn't sure how to re-write codes for ranges (ws.Range("x2:x" & lr)). All of the rng have the same amount of data (rows) so wasn't sure if I need to define it each time.
I want my result to be from D5 to N-1 in Table E-1... sheet. I used For i = 5 To lrow - 1 since there is a total in the last row.
In Table E-1 sheet, Column D have a list of zip codes and column E have a list of county that I am trying to match.
Except for how you use your CountIfs Function, since there are no screen-shots of your data, the code below will take care of your run-time errors.
Explanation for your run-time errors:
1.Wrong declaration, Dim ws, ws1 As Worksheet should be Dim ws As Worksheet, ws1 As Worksheet , otherwise ws is not defined as Worksheet. The same goes to all of your variables declarations.
2.Find last row in a column: lr = ws.Cells(Cells.Rows.Count, "D").End(xlUp).Row is wrong, it should be lr = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row.
3.Like #Scott Holtzman wrote in his comment, since you already set your rng in previous lines, (Set rng = ws.Range("D2:D" & lr)) , then it should be used with just rng and not ws.rng.
4.To improve and clean your code, you could just use With ws in the beginning of your code, and nest most of it related objects underneath.
"Clean" Code
Option Explicit
Sub counters()
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim lrow As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long
Dim ws As Worksheet, ws1 As Worksheet
Set ws = Sheets("Data")
Set ws1 = Sheets("Table E-1 Zip Codes PIF")
' last row in Column B in "Table E-1 Zip Codes PIF" sheet
lrow = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
With ws
lr = .Cells(.Rows.Count, "D").End(xlUp).Row
lr2 = .Cells(.Rows.Count, "X").End(xlUp).Row
lr3 = .Cells(.Rows.Count, "Y").End(xlUp).Row
lr4 = .Cells(.Rows.Count, "AE").End(xlUp).Row
'zip code
Set rng = .Range("D2:D" & lr)
'county
Set rng2 = .Range("X2:X" & lr2)
'Region
Set rng3 = .Range("Y2:Y" & lr3)
'policy form
Set rng4 = .Range("AE2:AE" & lr4)
For i = 5 To lrow - 1
ws1.Cells(i, 4).Value = Application.WorksheetFunction.CountIfs(rng, ws1.Cells(i, 2).Value, rng2, ws1.Cells(i, 3).Value, rng3, "NW", rng4, "Basic Choice")
Next i
End With
End Sub
I would really appreciate some help to find a correct approach to solve my issue.
I am attempting to loop through all worksheets (except for "Sheet 1" and "Output".
All the above referenced worksheets contain data from cell A2 to last column and last row. I need to copy all the looped ranges (one below the other) in cell C2 in my "Output" worksheet.
Also I have a unique number in A1 in all worksheets (except for "Sheet 1" and "Output" that needs to be copied into B2 in my "Output" worksheet. The trick is (which i am struggling with) the value in A1 needs to be copied down B2 in my "Output" worksheet by the number A2:last row in all my looped worksheets.
Below is my code thus far:
Sub EveryDayImShufflingData()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim Rng As Range
Dim lRow As Long
Dim lCol As Long
Dim maxRow As Integer
Dim x As String
Set PasteSheet = Worksheets("Output")
Application.ScreenUpdating = False
'Loop through worksheets except "Sheet 1" and "Output"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
'Select the Worksheet
ws.Select
'With each worksheet
With ws
'Declare variables lRow and lCol
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'Set range exc. VIN
Set Rng = .Range(.Cells(2, 1), .Cells(lRow, lCol))
'Paste the range into "Output" worksheet
Rng.Copy
PasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
x = .Cells(1, 1).Value
For i = 1 To lRow
PasteSheet.Cells(i, 2).End(xlUp).Offset(1, 0) = x
maxRow = maxRow + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End If
Next ws
End Sub
Any assistance would be kindly appreciated
Try this:
Sub EveryDayImShufflingData()
Dim ws As Worksheet, copyRng As Range, lRow As Long, lCol As Long, PasteSheet As Worksheet
Set PasteSheet = Worksheets("Output")
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set copyRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol))
copyTargetCell = PasteSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1
copyRng.Copy Destination:=PasteSheet.Range("C" & copyTargetCell)
Worksheets("Output").Range("B" & copyTargetCell & ":B" & (copyTargetCell + copyRng.Rows.Count - 1)) = ws.Range("A1")
End If
Next ws
End Sub
How can I take data from multiple sheets instead of just Sheet1?
Sub CheckRowsWithAutofilter()
Dim DataBlock As Range, Dest As Range
Dim LastRow As Long, LastCol As Long
Dim SheetOne As Worksheet, SheetTwo As Worksheet
'set references up-front
Set SheetOne = ThisWorkbook.Worksheets("Sheet1")
Set SheetTwo = ThisWorkbook.Worksheets("Sheet2")
Set Dest = SheetTwo.Cells(Last + 1, "A")
'enter code here
'identify the "data block" range, which is where
With SheetOne
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set DataBlock = .Range(.Cells(112, 7), .Cells(LastRow, LastCol))
End With
With DataBlock
.SpecialCells(xlCellTypeVisible).Copy Destination:=Dest
End With
End Sub
This should loop through each worksheet named in the vWSs variant array.
Sub CheckRowsWithAutofilter()
Dim lr As Long, lc As Long
Dim SheetTwo As Worksheet
Dim w As Long, vWSs As Variant
'set references up-front
vWSs = Array("Sheet1", "Sheet3", "Sheet4")
Set SheetTwo = ThisWorkbook.Worksheets("Sheet2")
'loop through the worksheets named in vWSs
For w = LBound(vWSs) To UBound(vWSs)
With Worksheets(vWSs(w))
lr = .Range("A" & .Rows.Count).End(xlUp).Row
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(112, 7), .Cells(lr, lc))
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
End With
Next w
End Sub
I cut out some of your variables as they were only used once and sometimes the code to declare and assign them was more than simply making the direct reference.