I am trying to copy cells from several worksheets to a summary worksheet if their date (held in col. G) falls within a given range. I want the macro to loop through column g in each sheet and pull in the information where there is a match before moving on to the next worksheet to do the same. Currently my code presents a compile error: Invalid qualifier for the x value within rng...I an new to VBA and can't see what I have done wrong.
Sub Copy_ProjectSummaryData()
Dim i As Integer
Dim ws_num As Integer
Dim rng As Range, destRow As Long
Dim starting_ws As Worksheet
Dim shtDest As Worksheet
Dim c As Range
Dim startdate As Date
Dim enddate As Date
Set starting_ws = ThisWorkbook.Worksheets(1) 'remember which worksheet is
active in the beginning
ws_num = ThisWorkbook.Worksheets.Count
Set shtDest = Sheets("Summary")
destRow = 4 'start copying to this row
destRow2 = 4 'start copying to this row
destRow3 = 4 'start copying to this row
destRow4 = 4 'start copying to this row
startdate = CDate(InputBox("Begining Date"))
enddate = CDate(InputBox("End Date"))
'Clear contents from sheet before running new report
Range("A4").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
'Find and pull in Escalated Risks within the date range for the report
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
Set rng =
Application.Intersect(ThisWorkbook.Worksheets(i).Range("G16:G20"),
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
If c.Value >= startdate And c.Value <= enddate Then
'Starting 6 cells to the left of c (col A),
' copy an 8-cell wide block to the other sheet,
' pasting it in Col B on row destRow
c.Offset(0, -6).Resize(1, 8).Copy _
shtDest.Cells(destRow, 2)
destRow = destRow + 1
End If
Next
Next
'Find and paste Risk Project Name
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
Set rng = Application.Intersect(ThisWorkbook.Worksheets(i).Range("G16:G20"),
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
If c.Value >= startdate And c.Value <= enddate Then
' copy C3 to the other sheet,
' pasting it in Col A on row destRow
Range("C3").Copy _
shtDest.Cells(destRow2, 1)
destRow2 = destRow2 + 1
End If
Next
Next
'Find and pull in New Issues within the date range for the report
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
Set rng =
Application.Intersect(ThisWorkbook.Worksheets(i).Range("G22:G26"),
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
If c.Value >= startdate And c.Value <= enddate Then
'Starting 6 cells to the left of c (col A),
' copy an 8-cell wide block to the other sheet,
' pasting it in Col B on row destRow
c.Offset(0, -6).Resize(1, 8).Copy _
shtDest.Cells(destRow3, 11)
destRow3 = destRow3 + 1
End If
Next
Next
'Find and paste Issues Project Name
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
Set rng =
Application.Intersect(ThisWorkbook.Worksheets(i).Range("G22:G26"),
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
If c.Value >= startdate And c.Value <= enddate Then
' copy C3 to the other sheet,
' pasting it in Col A on row destRow
Range("C3").Copy _
shtDest.Cells(destRow4, 10)
destRow4 = destRow4 + 1
End If
Next
Next
starting_ws.Activate 'activate the worksheet that was originally active
Range("B4").Select
Selection.Copy
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("K4").Select
Selection.Copy
Range("J4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
You have declared X as a Long. A Long does not have ranges. You should be using Sheets(X) rather than just X:
Set rng = Application.Intersect(Sheets(x).Range("G:G"), Sheets(x).UsedRange)
Related
I have written a code but it's not working
I want to copy a range F2:F24 from sheet1 and paste it to Sheet2 in incremental column-wise (Column_count+1), only if cell F2 value in sheet1 should not be equal to the last column of the first row in sheet2
If it matches then popup msgbox as "check_the _cell"
Here is my code
Sub copycolumns()
Dim TargetSheet As Object
Set TargetSheet = Sheets("sheet2")
Dim TargetColumn As Integer
Dim LastC As Long
TargetColumn = TargetSheet.Range("F1").CurrentRegion.Columns.Count + 1
LastC = TargetSheet.Cells(1, TargetSheet.Columns.Count).End(xlToLeft).Column
If LastC = Sheets("sheet1").Cells(2, 6).Value Then
MsgBox "check the cell"
ElseIf TargetSheet.Range("F1") = "" Then
TargetColumn = 6
End If
Sheets("sheet1").Range("F2:F24").Copy
TargetSheet.Activate
TargetSheet.Cells(1, TargetColumn).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Update_1: Before copying and pasting the RangeF2:F24 from Sheet1, it should compare the value of F2 (refer Image1) of Sheet1 and the last column of the first cell from sheet2 (Refer Image2, it is J1). If its value is the same then msgpop as error. if its value is different then copy F2:F24 and paste in last column of first row in sheet2
The line If LastC = Sheets("sheet1").Cells(2, 6).Value Then is comparing a column number with a date. Try
Option Explicit
Sub copycolumns()
Const COPY_RANGE = "F2:F24"
Const START_COL = 6 ' Target sheet F
Dim wb As Workbook, ws As Worksheet, wsTarget As Worksheet
Dim TargetColumn As Integer, LastColumn As Integer
Dim dtNew As Date, dtLast As Date
Dim rng As Range, rngTarget As Range
' source sheet 1
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set rng = ws.Range(COPY_RANGE)
dtNew = rng.Cells(1, 1).Value ' F2
' target sheet 2 row 1
Set wsTarget = wb.Sheets("Sheet2")
LastColumn = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
' check if exists
If LastColumn >= START_COL Then
dtLast = wsTarget.Cells(1, LastColumn)
If dtNew = dtLast Then
MsgBox Format(dtNew, "dd-mmm-yyyy") & " exists in Column " & LastColumn, vbCritical
Exit Sub
End If
Else
LastColumn = START_COL - 1
End If
TargetColumn = LastColumn + 1
' copy to target
rng.Copy
Set rngTarget = wsTarget.Cells(1, TargetColumn)
rngTarget.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'rngTarget.NumberFormat = "dd-mmm-yyyy"
Application.CutCopyMode = False
MsgBox Format(dtNew, "dd-mmm-yyyy") & " copied to column " & TargetColumn
End Sub
I'm working on a excel document with multiple seperate data, all in a single column (A1 to A10160).
All the data begins in a cell with the text NC/xx/xxxx/x (x being variable) and ending in a cell containing different dates but the cell above it always has the text "Start Date". Some data covers 49 cells others cover 51 cells so it's not contained in a fixed number of cells in the column.
I need to copy the range from NC/xx/xxxx/x to Start Date plus one for each data "set", transpose it and paste all the data in the column in a new sheet.
Really haven't found anything useful so far but I am fumbling with this one:
Sub Find()
Dim Search, End, Start, i As Integer, j As Integer, L
Search = Cells(1, 1)
End = Cells(2, 1)
For i = 1 To 10160
If Left(Cells(i, 1), 3) = Search Then
Start = i - 0
End If
Next i
For j = 1 To 10160
If Cells(j, 1) = End Then
L = j + 1
End If
Sheet4.Select
Range(Cells(Start, 1), Cells(L + 2, 1)).Select
Selection.Copy
Sheet4.Range("BB23").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End
Next j
End Sub
Would really appreciate any help I can get!
Thanks!
It looks like you haven't had much interest in your question, so I've taken a look at it. It's one of those fiddly jobs - not terribly technical but tricky to get the flow of logic right. The code below gives you what you've outlined in your question. You've said transpose it - so that's what the code does. Try it and let me know how you go.
Option Explicit
Sub Copy2Sheet2()
'Declare all your variables
Dim ws1 As Worksheet, ws2 As Worksheet
Dim topRow As Long, BottomRow As Long, LastRow As Long
Dim PasteToRow As Long, i As Long, c As Range
'Set the sheet variables
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
'Initial row settings
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<~~ assumes headers on sheet2
'Start the loop
For i = 1 To LastRow
'Find the bottom row of the first block of data
Set c = ws1.Range("A" & i & ":A" & LastRow).Find(What:="Start Date", LookIn:=xlValues)
BottomRow = c.Row + 1
'Define and copy the range to sheet2
ws1.Range("A" & i & ":A" & BottomRow).Copy
ws2.Range("A" & PasteToRow).PasteSpecial Transpose:=True
Application.CutCopyMode = False
'Redefine the 'paste to' row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Redefine the top row of the next block of data
i = BottomRow
'Repeat the process
Next i
End Sub
I have 5 columns of data. The data is grouped by employee name and number (cols A-B) and their respective pay types (col C). I need to
Copy employee name to blank cell below in col A
Copy employee number to blank cell below in col B
Add the word "Advance" in the blank cell in col C
Current code selects all blank cells in cols A-E and fills with the values from above:
Sub FillBlanksValueAbove1()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
This is what the spreadsheet looks like now:
This is what I need it to look like:
This is the end result I currently get:
Thank you so so much!
Test the next code, please. No need of any selection, a little simplified:
Sub FillBlanksValueAbove1()
Dim rng As Range, rngVis As Range
Dim ws As Worksheet, lastRow As Long
'Set variable ws Active Sheet name
Set ws = ActiveSheet
With ws
'Get the last row
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
'Set the range
Set rng = .Range(.cells(1, 1), .cells(lastRow, 2)) 'Col B:C
Set rngVis = rng.SpecialCells(xlCellTypeBlanks)
'Fill ADVANCE in column C:C
rngVis.Offset(, 1).Value = "ADVANCE"
'Fill Blanks with value above
rngVis.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rngVis.Value = rngVis.Value
End With
End Sub
I have a few non-contiguous ranges that may vary in size each time it is run. I would like to take each of the ranges and copy and paste them onto their own individual worksheets (one range per sheet).
My code currently works for the first range and sheet. After the second sheet is created, the ranges are highlighted, but the first range is again copied and pasted onto the second sheet, instead of the corresponding second range. Then, the third sheet is created, but again, only the first range is copied and pasted onto this sheet. I know something is wrong with my looping, but I can't figure out where.
I have exhausted all of my resources. I just can't figure out why the loop isn't getting to the other 2 ranges.
'Get current sheet name
Dim activeSheetName As String
activeSheetName = ActiveSheet.Name
'Create a new sheet to reformat existing data
Dim newSheetName As String
newSheetName = (activeSheetName + "_Data")
Dim filterRange As range
Dim areasCount As Integer
For Each a In filterRange.Areas
Sheets(newSheetName).Select
filterRange.Select
range(Selection, Selection.End(xlToRight)).Select
areasCount = Selection.Areas.Count
With a
For i = 2 To areasCount + 1
Selection.Copy
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
Selection.PasteSpecial paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=False
Application.CutCopyMode = False
End With
Next i
End With
Next a
I have tried to incorporate the following code I found in a book, but no such luck.
Dim SelAreas() As range
Dim pasteRange As range
Dim upperLeft As range
Dim numAreas As Long, i As Long
Dim topRow As Long, leftCol As Long
Dim rowOffset As Long, colOffset As Long
If TypeName(Selection) <> "Range" Then Exit Function
numAreas = Selection.Areas.Count
ReDim SelAreas(1 To numAreas)
For i = 1 To numAreas
Set SelAreas(i) = Selection.Areas(i)
Next
topRow = ActiveSheet.Rows.Count
leftCol = ActiveSheet.Columns.Count
For i = 1 To numAreas
If SelAreas(i).Row < topRow Then topRow = SelAreas(i).Row
If SelAreas(i).Column < leftCol Then leftCol = SelAreas(i).Column
Next
Set upperLeft = Cells(topRow, leftCol)
On Error Resume Next
Set pasteRange = range("A50")
On Error GoTo 0
If TypeName(pasteRange) <> "Range" Then Exit Function
Set pasteRange = pasteRange.range("A1")
For i = 1 To numAreas
rowOffset = SelAreas(i).Row - topRow
colOffset = SelAreas(i).Column - leftCol
SelAreas(i).Copy
range("A1").Value = pasteRange.Offset(rowOffset, colOffset)
Next i
For Each a In filterRange.Areas
Sheets(newSheetName).Select
range(a, a.End(xlToRight)).Copy
With a
If filterRange Is Nothing Then
MsgBox ("Value not present in this workbook.")
Else
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
ActiveSheet.paste
End With
range("A10:A49").Select
range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
range("A1").Select
End If
End With
Next a
Data is filter based on criteria in Col C.
copyRng.AutoFilter Field:=3, Criteria1:="<>"
Filter data is copied to another sheet. It works perfectly when there is at least one cell with data in that column but if the whole column is blank it copies all of the rows, however, it shouldn’t copy anything. What can be done fix this problem? Thank you
Public Sub CopyCLMData()
Dim ws As Worksheet
Dim maxCell As Range
Dim lRowAccess As Long
Dim lRowThisWS As Long
Dim lColThisWS As Long
Dim copyRng As Range, copyRng2 As Range
Dim startRow As Long
Dim startCol As Long
Dim maxXLRows As Long
startRow = 2
startCol = 1
Application.EnableEvents = False
Application.ScreenUpdating = False
'copy header row
wsAll.Rows(1).Copy
wsAccess.Rows(1).PasteSpecial xlPasteValues
'get summary counts only once (outside of the loop)
maxXLRows = wsAccess.Rows.Count 'total rows available in summary sheet
'Copy Colon, Lung, and Melanoma data to summary worksheet (Access)
For Each ws In Worksheets
If ws.name = WS_COLON Or ws.name = WS_LUNG Or ws.name = WS_MELA Then
lRowThisWS = ws.Range("A" & Rows.Count).End(xlUp).Row
Debug.Print lRowThisWS
lColThisWS = 35
'If last row >= StartRow, copy the range
Set copyRng = ws.Range(ws.Cells(startRow - 1, startCol), ws.Cells(lRowThisWS, lColThisWS)) 'data range
'copyRng.AutoFilter Field:=1, Criteria1:="<>*_QC*" 'hide QC rows
copyRng.AutoFilter Field:=3, Criteria1:="<>" 'hide blank rows in col C
If copyRng.SpecialCells(xlCellTypeVisible).Count > 1 Then 'if there is any visible data left
'copy visible range only
Set copyRng = copyRng.SpecialCells(xlCellTypeVisible).Range(copyRng.Cells(startRow, startCol), copyRng.Cells(lRowThisWS, lColThisWS))
copyRng.Copy 'copy values and formats
With wsAccess.Cells(lRowAccess + 1, "A")
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteFormulas
End With
End If
'copyRng.AutoFilter Field:=1
copyRng.AutoFilter Field:=3
End If
End If
Next
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub